typedef long int integer;
typedef unsigned long uinteger;
typedef char *address;
typedef short int shortint;
typedef float real;
typedef double doublereal;
typedef struct { real r, i; } complex;
typedef struct { doublereal r, i; } doublecomplex;
typedef long int logical;
typedef short int shortlogical;
typedef char logical1;
typedef char integer1;

typedef long int flag;
typedef long int ftnlen;
typedef long int ftnint;
 
typedef struct
{	flag cierr;
	ftnint ciunit;
	flag ciend;
	char *cifmt;
	ftnint cirec;
} cilist;
typedef struct
{	flag icierr;
	char *iciunit;
	flag iciend;
	char *icifmt;
	ftnint icirlen;
	ftnint icirnum;
} icilist;
typedef struct
{	flag oerr;
	ftnint ounit;
	char *ofnm;
	ftnlen ofnmlen;
	char *osta;
	char *oacc;
	char *ofm;
	ftnint orl;
	char *oblnk;
} olist;
typedef struct
{	flag cerr;
	ftnint cunit;
	char *csta;
} cllist;
typedef struct
{	flag aerr;
	ftnint aunit;
} alist;
typedef struct
{	flag inerr;
	ftnint inunit;
	char *infile;
	ftnlen infilen;
	ftnint	*inex;	 
	ftnint	*inopen;
	ftnint	*innum;
	ftnint	*innamed;
	char	*inname;
	ftnlen	innamlen;
	char	*inacc;
	ftnlen	inacclen;
	char	*inseq;
	ftnlen	inseqlen;
	char 	*indir;
	ftnlen	indirlen;
	char	*infmt;
	ftnlen	infmtlen;
	char	*inform;
	ftnint	informlen;
	char	*inunf;
	ftnlen	inunflen;
	ftnint	*inrecl;
	ftnint	*innrec;
	char	*inblank;
	ftnlen	inblanklen;
} inlist;



union Multitype {	 
	integer1 g;
	shortint h;
	integer i;
	 
	real r;
	doublereal d;
	complex c;
	doublecomplex z;
	};

typedef union Multitype Multitype;

 	 

struct Vardesc {	 
	char *name;
	char *addr;
	ftnlen *dims;
	int  type;
	};
typedef struct Vardesc Vardesc;

struct Namelist {
	char *name;
	Vardesc **vars;
	int nvars;
	};
typedef struct Namelist Namelist;

typedef int   (*U_fp)();
typedef shortint (*J_fp)();
typedef integer (*I_fp)();
typedef real (*R_fp)();
typedef doublereal (*D_fp)(), (*E_fp)();
typedef   void  (*C_fp)();
typedef   void  (*Z_fp)();
typedef logical (*L_fp)();
typedef shortlogical (*K_fp)();
typedef   void  (*H_fp)();
typedef   int (*S_fp)();
typedef void  C_f;	 
typedef void  H_f;	 
typedef void  Z_f;	 
typedef doublereal E_f;	 
struct {
    integer iero;
} ierode_;

struct {
    doublereal precis;
    integer iout, iprint;
} colout_;

struct {
    doublereal rho[7], coef[49];
} colloc_;

union {
    struct {
	integer k, nc, mstar, kd, mmax, mt[20];
    } _1;
    struct {
	integer k, ncomp, mstar, kd, mmax, m[20];
    } _2;
    struct {
	integer k, ncomp, id1, id2, mmax, m[20];
    } _3;
    struct {
	integer kdum, ncomp, mstar, kd, mmax, m[20];
    } _4;
    struct {
	integer kdum, ndum, mstar, kd, mmax, m[20];
    } _5;
    struct {
	integer k, ncdum, mstar, kdum, mmax, m[20];
    } _6;
    struct {
	integer k, ncomp, mstar, kdum, mmax, m[20];
    } _7;
} colord_;

struct {
    integer n, nold, nmax, nz, ndmz;
} colapr_;



struct {
    integer mshflg, mshnum, mshlmt, mshalt;
} colmsh_;



union {
    struct {
	doublereal tzeta[40], tleft, tright;
	integer izeta, idum;
    } _1;
    struct {
	doublereal zeta[40], aleft, aright;
	integer izeta, idum;
    } _2;
    struct {
	doublereal zeta[40], aleft, aright;
	integer izeta, izsave;
    } _3;
} colsid_;





struct {
    integer nonlin, iter, limit, icare, iguess;
} colnln_;



union {
    struct {
	doublereal ttl[40], wgtmsh[40], wgterr[40], tolin[40], root[40];
	integer jtol[40], lttol[40], ntol;
    } _1;
    struct {
	doublereal tol[40], wgtmsh[40], wgterr[40], tolin[40], root[40];
	integer jtol[40], ltol[40], ntol;
    } _2;
} colest_;




struct {
    integer iero;
} iercol_;



struct {
    doublereal b[28], acol[196]	 , asave[112]	 
;
} colbas_;



struct {
    integer nunit, iunit[5];
} xeruni_;



struct {
    integer iero;
} ierajf_;



struct {
    integer jupbnd;
} dqa001_;



union {
    struct {
	doublereal rownd, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn,
		 uround;
	integer iownd[14], iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, 
		l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, 
		nje, nqu;
    } _1;
    struct {
	doublereal tret, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, 
		uround;
	integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, mxstep, 
		mxhnil, nhnil, ntrep, nslast, nyh, iowns[6], icf, ierpj, 
		iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, 
		msbp, mxncf, n, nq, nst, nfe, nje, nqu;
    } _2;
    struct {
	doublereal tret, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn, 
		uround;
	integer illin, init, lyh, lewt, lacor, lsavr, lwm, liwm, mxstep, 
		mxhnil, nhnil, ntrep, nslast, nyh, iowns[6], icf, ierpj, 
		iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, 
		msbp, mxncf, n, nq, nst, nre, nje, nqu;
    } _3;
    struct {
	doublereal rownd, rowns[209], ccmax, el0, h__, hmin, hmxi, hu, rc, tn,
		 uround;
	integer iownd[14], iowns[6], icf, ierpj, iersl, jcur, jstart, kflag, 
		l, meth, miter, maxord, maxcor, msbp, mxncf, n, nq, nst, nre, 
		nje, nqu;
    } _4;
    struct {
	doublereal rls[219];
	integer ils[39];
    } _5;
    struct {
	doublereal rownd, conit, crate, el[13], elco[156]	 
, hold, rmax, tesco[36]	 , ccmax, el0,
		 h__, hmin, hmxi, hu, rc, tn, uround;
	integer iownd[14], ialth, ipup, lmax, meo, nqnyh, nslp, icf, ierpj, 
		iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, 
		msbp, mxncf, n, nq, nst, nfe, nje, nqu;
    } _6;
    struct {
	doublereal rownd, conit, crate, el[13], elco[156]	 
, hold, rmax, tesco[36]	 , ccmax, el0,
		 h__, hmin, hmxi, hu, rc, tn, uround;
	integer iownd[14], ialth, ipup, lmax, meo, nqnyh, nslp, icf, ierpj, 
		iersl, jcur, jstart, kflag, l, meth, miter, maxord, maxcor, 
		msbp, mxncf, n, nq, nst, nre, nje, nqu;
    } _7;
} ls0001_;









struct {
    doublereal stk[2000000];
} stack_;



struct {
    integer bot, top, idstk[3000]	 , lstk[500], leps, 
	    bbot, bot0;
} vstk_;



struct {
    integer ids[1536]	 , pstk[256], rstk[256], pt, niv, 
	    macr, paus, icall;
} recu_;



struct {
    integer ddt, err, lct[8], lin[8192], lpt[6], hio, rio, wio, rte, wte;
} iop_;



struct {
    integer err1, err2, errct, toperr;
} errgst_;



struct {
    integer sym, syn[6], char1, fin, fun, lhs, rhs, ran[2], comp[2];
} com_;



struct {
    char alfa[63], alfb[63], buf[4096];
} cha1_;



struct {
    integer nlink;
} link1_;



struct {
    char tablin[1000];
} link2_;



struct {
    integer wmac, lcntr, nmacs, macnms[120]	 , lgptrs[21],
	     bptlg[100];
} dbg_;



union {
    struct {
	doublereal tsw, rowns2[20], pdnorm;
	integer insufr, insufi, ixpr, iowns2[2], jtyp, mused, mxordn, mxords;
    } _1;
    struct {
	doublereal rownd2, rowns2[20], pdnorm;
	integer iownd2[3], iowns2[2], jtyp, mused, mxordn, mxords;
    } _2;
    struct {
	doublereal rlsa[22];
	integer ilsa[9];
    } _3;
    struct {
	doublereal rownd2, pdest, pdlast, ratio, cm1[12], cm2[5], pdnorm;
	integer iownd2[3], icount, irflag, jtyp, mused, mxordn, mxords;
    } _4;
} lsa001_;






union {
    struct {
	doublereal rownr3[2], t0, tlast, toutc;
	integer lg0, lg1, lgx, iownr3[2], irfnd, itaskc, ngc, nge;
    } _1;
    struct {
	doublereal rownr3[2], t0, tlast, toutc;
	integer iownd3[3], iownr3[2], irfnd, itaskc, ngc, nge;
    } _2;
    struct {
	doublereal alpha, x2, rdum3[3];
	integer iownd3[3], imax, last, idum3[4];
    } _3;
    struct {
	doublereal rlsr[5];
	integer ilsr[9];
    } _4;
} lsr001_;






struct {
    integer kmax, kount;
    doublereal dxsav, xp[200], yp[2000]	 ;
} path_;



union {
    struct {
	integer ieh[2];
    } _1;
    struct {
	integer mesflg, lunit;
    } _2;
} eh0001_;




struct {
    doublereal u1;
    integer nc;
} fprf2c_;



union {
    struct {
	doublereal t0, tf, dti, dtf, ermx;
	integer iu[5], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, 
		ntob, ntobi, nitu, ndtu;
    } _1;
    struct {
	doublereal t00, tf0, dti0, dtf0, ermx0;
	integer iu0[5], nuc0, nuv0, ilin0, nti0, ntf0, ny0, nea0, itmx0, nex0,
		 nob0, ntob0, ntobi0, nitu0, ndtu0;
    } _2;
} icsez_;




union {
    struct {
	integer nitv, nrtv, ndtv;
    } _1;
    struct {
	integer nitv0, nrtv0, ndtv0;
    } _2;
} nird_;




 

static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static doublereal c_b61 = 0.;
static integer c__0 = 0;
static doublereal c_b89 = 1.;
static doublereal c_b418 = -1.;
static doublereal c_b806 = .5;
static integer c__65 = 65;
static integer c__4 = 4;
static doublereal c_b1934 = .16666666666666666;
static doublereal c_b1936 = .33333333333333331;
static doublereal c_b1938 = .66666666666666663;
static doublereal c_b1940 = .83333333333333337;
static integer c_n998 = -998;
static integer c__5 = 5;
static integer c__6 = 6;
static integer c__7 = 7;
static integer c__8 = 8;
static integer c__9 = 9;
static integer c__10 = 10;
static integer c__11 = 11;
static integer c__12 = 12;
static integer c__13 = 13;
static integer c__14 = 14;
static integer c__15 = 15;
static integer c__17 = 17;
static integer c__18 = 18;
static integer c__19 = 19;
static integer c_n999 = -999;
static integer c__72 = 72;
static integer c__30 = 30;
static integer c__51 = 51;
static integer c__52 = 52;
static integer c__60 = 60;
static integer c__999 = 999;
static integer c__103 = 103;
static integer c__50 = 50;
static integer c__104 = 104;
static integer c__101 = 101;
static integer c__102 = 102;
static integer c__105 = 105;
static integer c__106 = 106;
static integer c__107 = 107;
static integer c__301 = 301;
static integer c__201 = 201;
static integer c__202 = 202;
static integer c__203 = 203;
static integer c__204 = 204;
static integer c__205 = 205;
static integer c__206 = 206;
static integer c__207 = 207;
static integer c__40 = 40;
static integer c__16 = 16;
static integer c__20 = 20;
static integer c__21 = 21;
static integer c__22 = 22;
static integer c__23 = 23;
static integer c__24 = 24;
static integer c__25 = 25;
static integer c__26 = 26;
static integer c__27 = 27;
static integer c__28 = 28;
static integer c__29 = 29;
static integer c__302 = 302;
static integer c__303 = 303;
static integer c__31 = 31;
static integer c__32 = 32;
static integer c__208 = 208;
static integer c__210 = 210;
static doublereal c_b5310 = 1.5;
static doublereal c_b5340 = 1e-4;
static doublereal c_b5732 = .9;
static doublereal c_b5779 = .75;
static logical c_false = (0) ;
static doublereal c_b7108 = .25;
static integer c_n24 = -24;
static integer c_n34 = -34;
static doublereal c_b8137 = 10.;

  int dgelq2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3;

     
    static integer i__, k;
    extern   int dlarf_(), dlarfg_(), xerbla_();
    static doublereal aii;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -4;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGELQ2", &i__1, 6L);
	return 0;
    }

    k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;

    i__1 = k;
    for (i__ = 1; i__ <= i__1; ++i__) {

 


	i__2 = *n - i__ + 1;
 
	i__3 = i__ + 1;
	dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + (( i__3 ) <= ( *n ) ? ( i__3 ) : ( *n ))  * a_dim1]
		, lda, &tau[i__]);
	if (i__ < *m) {

 

	    aii = a[i__ + i__ * a_dim1];
	    a[i__ + i__ * a_dim1] = 1.;
	    i__2 = *m - i__;
	    i__3 = *n - i__ + 1;
	    dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
		    i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L);
	    a[i__ + i__ * a_dim1] = aii;
	}
 
    }
    return 0;

}  

  int dgelqf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
    static integer i__, k, nbmin, iinfo;
    extern   int dgelq2_();
    static integer ib, nb;
    extern   int dlarfb_();
    static integer nx;
    extern   int dlarft_(), xerbla_();
    extern integer ilaenv_();
    static integer ldwork, iws;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -4;
    } else if (*lwork < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -7;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGELQF", &i__1, 6L);
	return 0;
    }

    k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    if (k == 0) {
	work[1] = 1.;
	return 0;
    }

    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
    nbmin = 2;
    nx = 0;
    iws = *m;
    if (nb > 1 && nb < k) {
 
	i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L,
		 1L);
	nx = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	if (nx < k) {
	    ldwork = *m;
	    iws = ldwork * nb;
	    if (*lwork < iws) {

 

 

		nb = *lwork / ldwork;
 
		i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, &
			c_n1, 6L, 1L);
		nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    }
	}
    }

    if (nb >= nbmin && nb < k && nx < k) {

 

	i__1 = k - nx;
	i__2 = nb;
	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
 
	    i__3 = k - i__ + 1;
	    ib = (( i__3 ) <= ( nb ) ? ( i__3 ) : ( nb )) ;

 
 

	    i__3 = *n - i__ + 1;
	    dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
		    1], &iinfo);
	    if (i__ + ib <= *m) {

 

 

		i__3 = *n - i__ + 1;
		dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * 
			a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L);

 

		i__3 = *m - i__ - ib + 1;
		i__4 = *n - i__ + 1;
		dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, 
			&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
			ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + 
			1], &ldwork, 5L, 12L, 7L, 7L);
	    }
 
	}
    } else {
	i__ = 1;
    }

 

    if (i__ <= k) {
	i__2 = *m - i__ + 1;
	i__1 = *n - i__ + 1;
	dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
		, &iinfo);
    }

    work[1] = (doublereal) iws;
    return 0;

}  

  int dgels_(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, 
	info, trans_len)
char *trans;
integer *m, *n, *nrhs;
doublereal *a;
integer *lda;
doublereal *b;
integer *ldb;
doublereal *work;
integer *lwork, *info;
ftnlen trans_len;
{
     
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;

     
    static doublereal anrm, bnrm;
    static integer brow;
    static logical tpsd;
    static integer i__, j, iascl, ibscl;
    extern logical lsame_();
    extern   int dtrsm_();
    static integer wsize;
    static doublereal rwork[1];
    extern   int dlabad_();
    static integer nb;
    extern doublereal dlamch_(), dlange_();
    static integer mn;
    extern   int dgelqf_(), dlascl_(), dgeqrf_(), dlaset_(), 
	    xerbla_();
    extern integer ilaenv_();
    static integer scllen;
    static doublereal bignum;
    extern   int dormlq_(), dormqr_();
    static doublereal smlnum;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = b_dim1 + 1;
    b -= b_offset;
    --work;

     
    *info = 0;
    mn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    if (! (lsame_(trans, "N", 1L, 1L) || lsame_(trans, "T", 1L, 1L))) {
	*info = -1;
    } else if (*m < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -6;
    } else   {
 
	i__1 = (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ;
	if (*ldb < (( i__1 ) >= ( *n ) ? ( i__1 ) : ( *n )) ) {
	    *info = -8;
	} else   {
 
 
	    i__3 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ;
	    i__1 = 1, i__2 = mn + (( i__3 ) >= ( *nrhs ) ? ( i__3 ) : ( *nrhs )) ;
	    if (*lwork < (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ) {
		*info = -10;
	    }
	}
    }

 

    if (*info == 0 || *info == -10) {

	tpsd = (1) ;
	if (lsame_(trans, "N", 1L, 1L)) {
	    tpsd = (0) ;
	}

	if (*m >= *n) {
	    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
	    if (tpsd) {
 
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
			c_n1, 6L, 2L);
		nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    } else {
 
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
			c_n1, 6L, 2L);
		nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    }
	} else {
	    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
	    if (tpsd) {
 
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
			c_n1, 6L, 2L);
		nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    } else {
 
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
			c_n1, 6L, 2L);
		nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    }
	}

 
	i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ;
	wsize = mn + (( i__1 ) >= ( *nrhs ) ? ( i__1 ) : ( *nrhs ))  * nb;
	work[1] = (doublereal) wsize;

    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGELS ", &i__1, 6L);
	return 0;
    }

 

 
    i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    if ((( i__1 ) <= ( *nrhs ) ? ( i__1 ) : ( *nrhs ))  == 0) {
	i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ;
	dlaset_("Full", &i__1, nrhs, &c_b61, &c_b61, &b[b_offset], ldb, 4L);
	return 0;
    }

 

    smlnum = dlamch_("S", 1L) / dlamch_("P", 1L);
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

 

    anrm = dlange_("M", m, n, &a[a_offset], lda, rwork, 1L);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

 

	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info, 1L);
	iascl = 1;
    } else if (anrm > bignum) {

 

	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info, 1L);
	iascl = 2;
    } else if (anrm == 0.) {

 

	i__1 = (( *m ) >= ( *n ) ? ( *m ) : ( *n )) ;
	dlaset_("F", &i__1, nrhs, &c_b61, &c_b61, &b[b_offset], ldb, 1L);
	goto L50;
    }

    brow = *m;
    if (tpsd) {
	brow = *n;
    }
    bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork, 1L);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

 

	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
		ldb, info, 1L);
	ibscl = 1;
    } else if (bnrm > bignum) {

 

	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
		ldb, info, 1L);
	ibscl = 2;
    }

    if (*m >= *n) {

 

	i__1 = *lwork - mn;
	dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

 

	if (! tpsd) {

 

 

	    i__1 = *lwork - mn;
	    dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 9L)
		    ;

 

 

	    dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &
		    c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 
		    8L);

	    scllen = *n;

	} else {

 

 

	    dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b89, 
		    &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 8L);

 

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = *n + 1; i__ <= i__2; ++i__) {
		    b[i__ + j * b_dim1] = 0.;
 
		}
 
	    }

 

	    i__1 = *lwork - mn;
	    dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 
		    4L, 12L);

 

	    scllen = *m;

	}

    } else {

 

	i__1 = *lwork - mn;
	dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

 

	if (! tpsd) {

 

 

	    dtrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &
		    c_b89, &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 
		    8L);

 

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = *m + 1; i__ <= i__2; ++i__) {
		    b[i__ + j * b_dim1] = 0.;
 
		}
 
	    }

 

	    i__1 = *lwork - mn;
	    dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 4L, 9L)
		    ;

 

	    scllen = *n;

	} else {

 

 

	    i__1 = *lwork - mn;
	    dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info, 
		    4L, 12L);

 

 

	    dtrsm_("Left", "Lower", "Transpose", "Non-unit", m, nrhs, &c_b89, 
		    &a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 8L);

	    scllen = *m;

	}

    }

 

    if (iascl == 1) {
	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
		, ldb, info, 1L);
    } else if (iascl == 2) {
	dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
		, ldb, info, 1L);
    }
    if (ibscl == 1) {
	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info, 1L);
    } else if (ibscl == 2) {
	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info, 1L);
    }

L50:
    work[1] = (doublereal) wsize;

    return 0;

}  

  int dgemm_(transa, transb, m, n, k, alpha, a, lda, b, ldb, 
	beta, c__, ldc, transa_len, transb_len)
char *transa, *transb;
integer *m, *n, *k;
doublereal *alpha, *a;
integer *lda;
doublereal *b;
integer *ldb;
doublereal *beta, *c__;
integer *ldc;
ftnlen transa_len;
ftnlen transb_len;
{
     
    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
	    i__3;
    static integer info;
    static logical nota, notb;
    static doublereal temp;
    static integer i__, j, l, ncola;
    extern logical lsame_();
    static integer nrowa, nrowb;
    extern   int xerbla_();
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = b_dim1 + 1;
    b -= b_offset;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;

     
    nota = lsame_(transa, "N", 1L, 1L);
    notb = lsame_(transb, "N", 1L, 1L);
    if (nota) {
	nrowa = *m;
	ncola = *k;
    } else {
	nrowa = *k;
	ncola = *m;
    }
    if (notb) {
	nrowb = *k;
    } else {
	nrowb = *n;
    }

 

    info = 0;
    if (! nota && ! lsame_(transa, "C", 1L, 1L) && ! lsame_(transa, "T", 1L, 
	    1L)) {
	info = 1;
    } else if (! notb && ! lsame_(transb, "C", 1L, 1L) && ! lsame_(transb, 
	    "T", 1L, 1L)) {
	info = 2;
    } else if (*m < 0) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*k < 0) {
	info = 5;
    } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) {
	info = 8;
    } else if (*ldb < (( 1 ) >= ( nrowb ) ? ( 1 ) : ( nrowb )) ) {
	info = 10;
    } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 13;
    }
    if (info != 0) {
	xerbla_("DGEMM ", &info, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
	return 0;
    }

 

    if (*alpha == 0.) {
	if (*beta == 0.) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    c__[i__ + j * c_dim1] = 0.;
 
		}
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
 
		}
 
	    }
	}
	return 0;
    }

 

    if (notb) {
	if (nota) {

 

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (*beta == 0.) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] = 0.;
 
		    }
		} else if (*beta != 1.) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
 
		    }
		}
		i__2 = *k;
		for (l = 1; l <= i__2; ++l) {
		    if (b[l + j * b_dim1] != 0.) {
			temp = *alpha * b[l + j * b_dim1];
			i__3 = *m;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
				    a_dim1];
 
			}
		    }
 
		}
 
	    }
	} else {

 

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = 0.;
		    i__3 = *k;
		    for (l = 1; l <= i__3; ++l) {
			temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
 
		    }
		    if (*beta == 0.) {
			c__[i__ + j * c_dim1] = *alpha * temp;
		    } else {
			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
				i__ + j * c_dim1];
		    }
 
		}
 
	    }
	}
    } else {
	if (nota) {

 

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (*beta == 0.) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] = 0.;
 
		    }
		} else if (*beta != 1.) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
 
		    }
		}
		i__2 = *k;
		for (l = 1; l <= i__2; ++l) {
		    if (b[j + l * b_dim1] != 0.) {
			temp = *alpha * b[j + l * b_dim1];
			i__3 = *m;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
				    a_dim1];
 
			}
		    }
 
		}
 
	    }
	} else {

 

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = 0.;
		    i__3 = *k;
		    for (l = 1; l <= i__3; ++l) {
			temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
 
		    }
		    if (*beta == 0.) {
			c__[i__ + j * c_dim1] = *alpha * temp;
		    } else {
			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
				i__ + j * c_dim1];
		    }
 
		}
 
	    }
	}
    }

    return 0;

 

}  

  int dgemv_(trans, m, n, alpha, a, lda, x, incx, beta, y, 
	incy, trans_len)
char *trans;
integer *m, *n;
doublereal *alpha, *a;
integer *lda;
doublereal *x;
integer *incx;
doublereal *beta, *y;
integer *incy;
ftnlen trans_len;
{
     
    integer a_dim1, a_offset, i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer lenx, leny, i__, j;
    extern logical lsame_();
    static integer ix, iy, jx, jy, kx, ky;
    extern   int xerbla_();
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --x;
    --y;

     
    info = 0;
    if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) && ! 
	    lsame_(trans, "C", 1L, 1L)) {
	info = 1;
    } else if (*m < 0) {
	info = 2;
    } else if (*n < 0) {
	info = 3;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 6;
    } else if (*incx == 0) {
	info = 8;
    } else if (*incy == 0) {
	info = 11;
    }
    if (info != 0) {
	xerbla_("DGEMV ", &info, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
	return 0;
    }

 

 

    if (lsame_(trans, "N", 1L, 1L)) {
	lenx = *n;
	leny = *m;
    } else {
	lenx = *m;
	leny = *n;
    }
    if (*incx > 0) {
	kx = 1;
    } else {
	kx = 1 - (lenx - 1) * *incx;
    }
    if (*incy > 0) {
	ky = 1;
    } else {
	ky = 1 - (leny - 1) * *incy;
    }

 
 

 

    if (*beta != 1.) {
	if (*incy == 1) {
	    if (*beta == 0.) {
		i__1 = leny;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[i__] = 0.;
 
		}
	    } else {
		i__1 = leny;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[i__] = *beta * y[i__];
 
		}
	    }
	} else {
	    iy = ky;
	    if (*beta == 0.) {
		i__1 = leny;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[iy] = 0.;
		    iy += *incy;
 
		}
	    } else {
		i__1 = leny;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[iy] = *beta * y[iy];
		    iy += *incy;
 
		}
	    }
	}
    }
    if (*alpha == 0.) {
	return 0;
    }
    if (lsame_(trans, "N", 1L, 1L)) {

 

	jx = kx;
	if (*incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0.) {
		    temp = *alpha * x[jx];
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			y[i__] += temp * a[i__ + j * a_dim1];
 
		    }
		}
		jx += *incx;
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0.) {
		    temp = *alpha * x[jx];
		    iy = ky;
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			y[iy] += temp * a[i__ + j * a_dim1];
			iy += *incy;
 
		    }
		}
		jx += *incx;
 
	    }
	}
    } else {

 

	jy = ky;
	if (*incx == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp = 0.;
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp += a[i__ + j * a_dim1] * x[i__];
 
		}
		y[jy] += *alpha * temp;
		jy += *incy;
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp = 0.;
		ix = kx;
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp += a[i__ + j * a_dim1] * x[ix];
		    ix += *incx;
 
		}
		y[jy] += *alpha * temp;
		jy += *incy;
 
	    }
	}
    }

    return 0;

 

}  

  int dgeqr2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3;

     
    static integer i__, k;
    extern   int dlarf_(), dlarfg_(), xerbla_();
    static doublereal aii;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;

     
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -4;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGEQR2", &i__1, 6L);
	return 0;
    }

    k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;

    i__1 = k;
    for (i__ = 1; i__ <= i__1; ++i__) {

 


	i__2 = *m - i__ + 1;
 
	i__3 = i__ + 1;
	dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[(( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m ))  + i__ * a_dim1]
		, &c__1, &tau[i__]);
	if (i__ < *n) {

 

	    aii = a[i__ + i__ * a_dim1];
	    a[i__ + i__ * a_dim1] = 1.;
	    i__2 = *m - i__ + 1;
	    i__3 = *n - i__;
	    dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
		    i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
	    a[i__ + i__ * a_dim1] = aii;
	}
 
    }
    return 0;

 

}  

  int dgeqrf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;

     
    static integer i__, k, nbmin, iinfo;
    extern   int dgeqr2_();
    static integer ib, nb;
    extern   int dlarfb_();
    static integer nx;
    extern   int dlarft_(), xerbla_();
    extern integer ilaenv_();
    static integer ldwork, iws;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;

     
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -4;
    } else if (*lwork < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	*info = -7;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGEQRF", &i__1, 6L);
	return 0;
    }

 

    k = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    if (k == 0) {
	work[1] = 1.;
	return 0;
    }

 

    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
    nbmin = 2;
    nx = 0;
    iws = *n;
    if (nb > 1 && nb < k) {

 


 
	i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L,
		 1L);
	nx = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	if (nx < k) {

 


	    ldwork = *n;
	    iws = ldwork * nb;
	    if (*lwork < iws) {

 

 

		nb = *lwork / ldwork;
 
		i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
			c_n1, 6L, 1L);
		nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	    }
	}
    }

    if (nb >= nbmin && nb < k && nx < k) {

 

	i__1 = k - nx;
	i__2 = nb;
	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
 
	    i__3 = k - i__ + 1;
	    ib = (( i__3 ) <= ( nb ) ? ( i__3 ) : ( nb )) ;

 
 

	    i__3 = *m - i__ + 1;
	    dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
		    1], &iinfo);
	    if (i__ + ib <= *n) {

 

 

		i__3 = *m - i__ + 1;
		dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * 
			a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L);

 

		i__3 = *m - i__ + 1;
		i__4 = *n - i__ - ib + 1;
		dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
			i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
			ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib 
			+ 1], &ldwork, 4L, 9L, 7L, 10L);
	    }
 
	}
    } else {
	i__ = 1;
    }

 

    if (i__ <= k) {
	i__2 = *m - i__ + 1;
	i__1 = *n - i__ + 1;
	dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
		, &iinfo);
    }

    work[1] = (doublereal) iws;
    return 0;

 

}  

  int dger_(m, n, alpha, x, incx, y, incy, a, lda)
integer *m, *n;
doublereal *alpha, *x;
integer *incx;
doublereal *y;
integer *incy;
doublereal *a;
integer *lda;
{
     
    integer a_dim1, a_offset, i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, ix, jy, kx;
    extern   int xerbla_();
    --x;
    --y;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    info = 0;
    if (*m < 0) {
	info = 1;
    } else if (*n < 0) {
	info = 2;
    } else if (*incx == 0) {
	info = 5;
    } else if (*incy == 0) {
	info = 7;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 9;
    }
    if (info != 0) {
	xerbla_("DGER  ", &info, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *alpha == 0.) {
	return 0;
    }

 
 

    if (*incy > 0) {
	jy = 1;
    } else {
	jy = 1 - (*n - 1) * *incy;
    }
    if (*incx == 1) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    if (y[jy] != 0.) {
		temp = *alpha * y[jy];
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    a[i__ + j * a_dim1] += x[i__] * temp;
 
		}
	    }
	    jy += *incy;
 
	}
    } else {
	if (*incx > 0) {
	    kx = 1;
	} else {
	    kx = 1 - (*m - 1) * *incx;
	}
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    if (y[jy] != 0.) {
		temp = *alpha * y[jy];
		ix = kx;
		i__2 = *m;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    a[i__ + j * a_dim1] += x[ix] * temp;
		    ix += *incx;
 
		}
	    }
	    jy += *incy;
 
	}
    }

    return 0;

 

}  

  int dlabad_(small, large)
doublereal *small, *large;
{
     
    double d_lg10(), sqrt();

    if (d_lg10(large) > 2e3) {
	*small = sqrt(*small);
	*large = sqrt(*large);
    }

    return 0;

 

}  

  int dlacon_(n, v, x, isgn, est, kase)
integer *n;
doublereal *v, *x;
integer *isgn;
doublereal *est;
integer *kase;
{
     
    integer i__1;
    doublereal d__1;

     
    double d_sign();
    integer i_dnnt();

     
    static integer iter;
    static doublereal temp;
    static integer jump, i__, j;
    extern doublereal dasum_();
    static integer jlast;
    extern   int dcopy_();
    extern integer idamax_();
    static doublereal altsgn, estold;
     
    --isgn;
    --x;
    --v;

     
    if (*kase == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    x[i__] = 1. / (doublereal) (*n);
 
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch ((int)jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

 
 

L20:
    if (*n == 1) {
	v[1] = x[1];
	*est = (( v[1] ) >= 0 ? ( v[1] ) : -( v[1] )) ;
 
	goto L150;
    }
    *est = dasum_(n, &x[1], &c__1);

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b89, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
 
    }
    *kase = 2;
    jump = 2;
    return 0;

 
 

L40:
    j = idamax_(n, &x[1], &c__1);
    iter = 2;

 

L50:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = 0.;
 
    }
    x[j] = 1.;
    *kase = 1;
    jump = 3;
    return 0;

 
 

L70:
    dcopy_(n, &x[1], &c__1, &v[1], &c__1);
    estold = *est;
    *est = dasum_(n, &v[1], &c__1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__1 = d_sign(&c_b89, &x[i__]);
	if (i_dnnt(&d__1) != isgn[i__]) {
	    goto L90;
	}
 
    }
 
    goto L120;

L90:
 
    if (*est <= estold) {
	goto L120;
    }

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = d_sign(&c_b89, &x[i__]);
	isgn[i__] = i_dnnt(&x[i__]);
 
    }
    *kase = 2;
    jump = 4;
    return 0;

 
 

L110:
    jlast = j;
    j = idamax_(n, &x[1], &c__1);
    if (x[jlast] != (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) && iter < 5) {
	++iter;
	goto L50;
    }

 

L120:
    altsgn = 1.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 
		1.);
	altsgn = -altsgn;
 
    }
    *kase = 1;
    jump = 5;
    return 0;

 
 

L140:
    temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
    if (temp > *est) {
	dcopy_(n, &x[1], &c__1, &v[1], &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

 

}  

  int dlae2_(a, b, c__, rt1, rt2)
doublereal *a, *b, *c__, *rt1, *rt2;
{
     
    doublereal d__1;

     
    double sqrt();

     
    static doublereal acmn, acmx, ab, df, tb, sm, rt, adf;

    sm = *a + *c__;
    df = *a - *c__;
    adf = (( df ) >= 0 ? ( df ) : -( df )) ;
    tb = *b + *b;
    ab = (( tb ) >= 0 ? ( tb ) : -( tb )) ;
    if ((( *a ) >= 0 ? ( *a ) : -( *a ))  > (( *c__ ) >= 0 ? ( *c__ ) : -( *c__ )) ) {
	acmx = *a;
	acmn = *c__;
    } else {
	acmx = *c__;
	acmn = *a;
    }
    if (adf > ab) {
 
	d__1 = ab / adf;
	rt = adf * sqrt(d__1 * d__1 + 1.);
    } else if (adf < ab) {
 
	d__1 = adf / ab;
	rt = ab * sqrt(d__1 * d__1 + 1.);
    } else {

 

	rt = ab * sqrt(2.);
    }
    if (sm < 0.) {
	*rt1 = (sm - rt) * .5;

 
 
 

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else if (sm > 0.) {
	*rt1 = (sm + rt) * .5;

 
 
 

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else {

 

	*rt1 = rt * .5;
	*rt2 = rt * -.5;
    }
    return 0;

 

}  

  int dlaev2_(a, b, c__, rt1, rt2, cs1, sn1)
doublereal *a, *b, *c__, *rt1, *rt2, *cs1, *sn1;
{
     
    doublereal d__1;

     
    double sqrt();

     
    static doublereal acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
    static integer sgn1, sgn2;
    sm = *a + *c__;
    df = *a - *c__;
    adf = (( df ) >= 0 ? ( df ) : -( df )) ;
    tb = *b + *b;
    ab = (( tb ) >= 0 ? ( tb ) : -( tb )) ;
    if ((( *a ) >= 0 ? ( *a ) : -( *a ))  > (( *c__ ) >= 0 ? ( *c__ ) : -( *c__ )) ) {
	acmx = *a;
	acmn = *c__;
    } else {
	acmx = *c__;
	acmn = *a;
    }
    if (adf > ab) {
 
	d__1 = ab / adf;
	rt = adf * sqrt(d__1 * d__1 + 1.);
    } else if (adf < ab) {
 
	d__1 = adf / ab;
	rt = ab * sqrt(d__1 * d__1 + 1.);
    } else {

 

	rt = ab * sqrt(2.);
    }
    if (sm < 0.) {
	*rt1 = (sm - rt) * .5;
	sgn1 = -1;

 
 
 

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else if (sm > 0.) {
	*rt1 = (sm + rt) * .5;
	sgn1 = 1;

 
 
 

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else {

 

	*rt1 = rt * .5;
	*rt2 = rt * -.5;
	sgn1 = 1;
    }

 

    if (df >= 0.) {
	cs = df + rt;
	sgn2 = 1;
    } else {
	cs = df - rt;
	sgn2 = -1;
    }
    acs = (( cs ) >= 0 ? ( cs ) : -( cs )) ;
    if (acs > ab) {
	ct = -tb / cs;
	*sn1 = 1. / sqrt(ct * ct + 1.);
	*cs1 = ct * *sn1;
    } else {
	if (ab == 0.) {
	    *cs1 = 1.;
	    *sn1 = 0.;
	} else {
	    tn = -cs / tb;
	    *cs1 = 1. / sqrt(tn * tn + 1.);
	    *sn1 = tn * *cs1;
	}
    }
    if (sgn1 == sgn2) {
	tn = *cs1;
	*cs1 = -(*sn1);
	*sn1 = tn;
    }
    return 0;

 

}  

doublereal dlamch_(cmach, cmach_len)
char *cmach;
ftnlen cmach_len;
{
     

    static logical first = (1) ;

     
    integer i__1;
    doublereal ret_val;

     
    double pow_di();

     
    static doublereal base;
    static integer beta;
    static doublereal emin, prec, emax;
    static integer imin, imax;
    static logical lrnd;
    static doublereal rmin, rmax, t, rmach;
    extern logical lsame_();
    static doublereal small, sfmin;
    extern   int dlamc2_();
    static integer it;
    static doublereal rnd, eps;

    if (first) {
	first = (0) ;
	dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
	base = (doublereal) beta;
	t = (doublereal) it;
	if (lrnd) {
	    rnd = 1.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1) / 2;
	} else {
	    rnd = 0.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1);
	}
	prec = eps * base;
	emin = (doublereal) imin;
	emax = (doublereal) imax;
	sfmin = rmin;
	small = 1. / rmax;
	if (small >= sfmin) {

 

 

	    sfmin = small * (eps + 1.);
	}
    }

    if (lsame_(cmach, "E", 1L, 1L)) {
	rmach = eps;
    } else if (lsame_(cmach, "S", 1L, 1L)) {
	rmach = sfmin;
    } else if (lsame_(cmach, "B", 1L, 1L)) {
	rmach = base;
    } else if (lsame_(cmach, "P", 1L, 1L)) {
	rmach = prec;
    } else if (lsame_(cmach, "N", 1L, 1L)) {
	rmach = t;
    } else if (lsame_(cmach, "R", 1L, 1L)) {
	rmach = rnd;
    } else if (lsame_(cmach, "M", 1L, 1L)) {
	rmach = emin;
    } else if (lsame_(cmach, "U", 1L, 1L)) {
	rmach = rmin;
    } else if (lsame_(cmach, "L", 1L, 1L)) {
	rmach = emax;
    } else if (lsame_(cmach, "O", 1L, 1L)) {
	rmach = rmax;
    }

    ret_val = rmach;
    return ret_val;

 

}  


 

  int dlamc1_(beta, t, rnd, ieee1)
integer *beta, *t;
logical *rnd, *ieee1;
{
     

    static logical first = (1) ;

     
    doublereal d__1, d__2;

     
    static logical lrnd;
    static doublereal a, b, c__, f;
    static integer lbeta;
    static doublereal savec;
    extern doublereal dlamc3_();
    static logical lieee1;
    static doublereal t1, t2;
    static integer lt;
    static doublereal one, qtr;

    if (first) {
	first = (0) ;
	one = 1.;

	a = 1.;
	c__ = 1.;

 
L10:
	if (c__ == one) {
	    a *= 2;
	    c__ = dlamc3_(&a, &one);
	    d__1 = -a;
	    c__ = dlamc3_(&c__, &d__1);
	    goto L10;
	}
 

 

 

 

	b = 1.;
	c__ = dlamc3_(&a, &b);

 
L20:
	if (c__ == a) {
	    b *= 2;
	    c__ = dlamc3_(&a, &b);
	    goto L20;
	}
 

 

 

 

 

	qtr = one / 4;
	savec = c__;
	d__1 = -a;
	c__ = dlamc3_(&c__, &d__1);
	lbeta = (integer) (c__ + qtr);

 

 


	b = (doublereal) lbeta;
	d__1 = b / 2;
	d__2 = -b / 100;
	f = dlamc3_(&d__1, &d__2);
	c__ = dlamc3_(&f, &a);
	if (c__ == a) {
	    lrnd = (1) ;
	} else {
	    lrnd = (0) ;
	}
	d__1 = b / 2;
	d__2 = b / 100;
	f = dlamc3_(&d__1, &d__2);
	c__ = dlamc3_(&f, &a);
	if (lrnd && c__ == a) {
	    lrnd = (0) ;
	}

 

 

 

 

 

	d__1 = b / 2;
	t1 = dlamc3_(&d__1, &a);
	d__1 = b / 2;
	t2 = dlamc3_(&d__1, &savec);
	lieee1 = t1 == a && t2 > savec && lrnd;

 

 

 

 

 

	lt = 0;
	a = 1.;
	c__ = 1.;

 
L30:
	if (c__ == one) {
	    ++lt;
	    a *= lbeta;
	    c__ = dlamc3_(&a, &one);
	    d__1 = -a;
	    c__ = dlamc3_(&c__, &d__1);
	    goto L30;
	}
 

    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *ieee1 = lieee1;
    return 0;

 

}  


 

  int dlamc2_(beta, t, rnd, eps, emin, rmin, emax, rmax)
integer *beta, *t;
logical *rnd;
doublereal *eps;
integer *emin;
doublereal *rmin;
integer *emax;
doublereal *rmax;
{
     

    static logical first = (1) ;
    static logical iwarn = (0) ;

     
    static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorrect:-\002,\002  EMIN = \002,i8,/\002 If, after inspection, the value EMIN looks\002,\002 acceptable please comment out \002,/\002 the IF block as marked within the code of routine\002,\002 DLAMC2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";

     
    integer i__1;
    doublereal d__1, d__2, d__3, d__4, d__5;

     
    double pow_di();
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static logical ieee;
    static doublereal half;
    static logical lrnd;
    static doublereal leps, zero, a, b, c__;
    static integer i__, lbeta;
    static doublereal rbase;
    static integer lemin, lemax, gnmin;
    static doublereal small;
    static integer gpmin;
    static doublereal third, lrmin, lrmax, sixth;
    extern   int dlamc1_();
    extern doublereal dlamc3_();
    static logical lieee1;
    extern   int dlamc4_(), dlamc5_();
    static integer lt, ngnmin, ngpmin;
    static doublereal one, two;
    static cilist io___156 = { 0, 6, 0, fmt_9999, 0 };
 

    if (first) {
	first = (0) ;
	zero = 0.;
	one = 1.;
	two = 2.;
	dlamc1_(&lbeta, &lt, &lrnd, &lieee1);

	b = (doublereal) lbeta;
	i__1 = -lt;
	a = pow_di(&b, &i__1);
	leps = a;

 


	b = two / 3;
	half = one / 2;
	d__1 = -half;
	sixth = dlamc3_(&b, &d__1);
	third = dlamc3_(&sixth, &sixth);
	d__1 = -half;
	b = dlamc3_(&third, &d__1);
	b = dlamc3_(&b, &sixth);
	b = (( b ) >= 0 ? ( b ) : -( b )) ;
	if (b < leps) {
	    b = leps;
	}

	leps = 1.;

 
L10:
	if (leps > b && b > zero) {
	    leps = b;
	    d__1 = half * leps;
 
	    d__3 = two, d__4 = d__3, d__3 *= d__3;
 
	    d__5 = leps;
	    d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
	    c__ = dlamc3_(&d__1, &d__2);
	    d__1 = -c__;
	    c__ = dlamc3_(&half, &d__1);
	    b = dlamc3_(&half, &c__);
	    d__1 = -b;
	    c__ = dlamc3_(&half, &d__1);
	    b = dlamc3_(&half, &c__);
	    goto L10;
	}
 

	if (a < leps) {
	    leps = a;
	}

	rbase = one / lbeta;
	small = one;
	for (i__ = 1; i__ <= 3; ++i__) {
	    d__1 = small * rbase;
	    small = dlamc3_(&d__1, &zero);
 
	}
	a = dlamc3_(&one, &small);
	dlamc4_(&ngpmin, &one, &lbeta);
	d__1 = -one;
	dlamc4_(&ngnmin, &d__1, &lbeta);
	dlamc4_(&gpmin, &a, &lbeta);
	d__1 = -a;
	dlamc4_(&gnmin, &d__1, &lbeta);
	ieee = (0) ;

	if (ngpmin == ngnmin && gpmin == gnmin) {
	    if (ngpmin == gpmin) {
		lemin = ngpmin;
 

 
	    } else if (gpmin - ngpmin == 3) {
		lemin = ngpmin - 1 + lt;
		ieee = (1) ;
 

 
	    } else {
		lemin = (( ngpmin ) <= ( gpmin ) ? ( ngpmin ) : ( gpmin )) ;
 
		iwarn = (1) ;
	    }

	} else if (ngpmin == gpmin && ngnmin == gnmin) {
	    if ((i__1 = ngpmin - ngnmin, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) ) == 1) {
		lemin = (( ngpmin ) >= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ;
 

 
	    } else {
		lemin = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ;
 
		iwarn = (1) ;
	    }

	} else if ((i__1 = ngpmin - ngnmin, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) ) == 1 && gpmin == gnmin)
		 {
	    if (gpmin - (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin ))  == 3) {
		lemin = (( ngpmin ) >= ( ngnmin ) ? ( ngpmin ) : ( ngnmin ))  - 1 + lt;
 

 
	    } else {
		lemin = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) ;
 
		iwarn = (1) ;
	    }

	} else {
 
	    i__1 = (( ngpmin ) <= ( ngnmin ) ? ( ngpmin ) : ( ngnmin )) , i__1 = (( i__1 ) <= ( gpmin ) ? ( i__1 ) : ( gpmin )) ;
	    lemin = (( i__1 ) <= ( gnmin ) ? ( i__1 ) : ( gnmin )) ;
 
	    iwarn = (1) ;
	}
 
 
	if (iwarn) {
	    first = (1) ;
	    s_wsfe(&io___156);
	    do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
 

 

 

 

 

	ieee = ieee || lieee1;

 

 

 

	lrmin = 1.;
	i__1 = 1 - lemin;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    d__1 = lrmin * rbase;
	    lrmin = dlamc3_(&d__1, &zero);
 
	}

 

	dlamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *eps = leps;
    *emin = lemin;
    *rmin = lrmin;
    *emax = lemax;
    *rmax = lrmax;

    return 0;
}  
 

doublereal dlamc3_(a, b)
doublereal *a, *b;
{
     
    doublereal ret_val;
    ret_val = *a + *b;

    return ret_val;

}  
 

  int dlamc4_(emin, start, base)
integer *emin;
doublereal *start;
integer *base;
{
     
    integer i__1;
    doublereal d__1;

     
    static doublereal zero, a;
    static integer i__;
    static doublereal rbase, b1, b2, c1, c2, d1, d2;
    extern doublereal dlamc3_();
    static doublereal one;

    a = *start;
    one = 1.;
    rbase = one / *base;
    zero = 0.;
    *emin = 1;
    d__1 = a * rbase;
    b1 = dlamc3_(&d__1, &zero);
    c1 = a;
    c2 = a;
    d1 = a;
    d2 = a;
 
 
L10:
    if (c1 == a && c2 == a && d1 == a && d2 == a) {
	--(*emin);
	a = b1;
	d__1 = a / *base;
	b1 = dlamc3_(&d__1, &zero);
	d__1 = b1 * *base;
	c1 = dlamc3_(&d__1, &zero);
	d1 = zero;
	i__1 = *base;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    d1 += b1;
 
	}
	d__1 = a * rbase;
	b2 = dlamc3_(&d__1, &zero);
	d__1 = b2 / rbase;
	c2 = dlamc3_(&d__1, &zero);
	d2 = zero;
	i__1 = *base;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    d2 += b2;
 
	}
	goto L10;
    }
 

    return 0;

 

}  


 

  int dlamc5_(beta, p, emin, ieee, emax, rmax)
integer *beta, *p, *emin;
logical *ieee;
integer *emax;
doublereal *rmax;
{
     
    integer i__1;
    doublereal d__1;

     
    static integer lexp;
    static doublereal oldy;
    static integer uexp, i__;
    static doublereal y, z__;
    static integer nbits;
    extern doublereal dlamc3_();
    static doublereal recbas;
    static integer exbits, expsum, try__;
 

    lexp = 1;
    exbits = 1;
L10:
    try__ = lexp << 1;
    if (try__ <= -(*emin)) {
	lexp = try__;
	++exbits;
	goto L10;
    }
    if (lexp == -(*emin)) {
	uexp = lexp;
    } else {
	uexp = try__;
	++exbits;
    }

 
 
 

    if (uexp + *emin > -lexp - *emin) {
	expsum = lexp << 1;
    } else {
	expsum = uexp << 1;
    }

 
 

    *emax = expsum + *emin - 1;
    nbits = exbits + 1 + *p;
    if (nbits % 2 == 1 && *beta == 2) {
	--(*emax);
    }

    if (*ieee) {

	--(*emax);
    }

    recbas = 1. / *beta;
    z__ = *beta - 1.;
    y = 0.;
    i__1 = *p;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z__ *= recbas;
	if (y < 1.) {
	    oldy = y;
	}
	y = dlamc3_(&y, &z__);
 
    }
    if (y >= 1.) {
	y = oldy;
    }

 

    i__1 = *emax;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__1 = y * *beta;
	y = dlamc3_(&d__1, &c_b61);
 
    }

    *rmax = y;
    return 0;

 

}  

doublereal dlange_(norm, m, n, a, lda, work, norm_len)
char *norm;
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
{
     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal ret_val, d__1, d__2, d__3;

     
    double sqrt();

     
    static integer i__, j;
    static doublereal scale;
    extern logical lsame_();
    static doublereal value;
    extern   int dlassq_();
    static doublereal sum;

     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --work;

     
    if ((( *m ) <= ( *n ) ? ( *m ) : ( *n ))  == 0) {
	value = 0.;
    } else if (lsame_(norm, "M", 1L, 1L)) {

 

	value = 0.;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
 
		d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	    }
 
	}
    } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {

 

	value = 0.;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    sum = 0.;
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
	    }
	    value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ;
 
	}
    } else if (lsame_(norm, "I", 1L, 1L)) {

 

	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    work[i__] = 0.;
 
	}
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
	    }
 
	}
	value = 0.;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__1 = value, d__2 = work[i__];
	    value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	}
    } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {

 

	scale = 0.;
	sum = 1.;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
 
	}
	value = scale * sqrt(sum);
    }

    ret_val = value;
    return ret_val;

 

}  

doublereal dlansp_(norm, uplo, n, ap, work, norm_len, uplo_len)
char *norm, *uplo;
integer *n;
doublereal *ap, *work;
ftnlen norm_len;
ftnlen uplo_len;
{
     
    integer i__1, i__2;
    doublereal ret_val, d__1, d__2, d__3;

     
    double sqrt();

     
    static doublereal absa;
    static integer i__, j, k;
    static doublereal scale;
    extern logical lsame_();
    static doublereal value;
    extern   int dlassq_();
    static doublereal sum;

     
    --work;
    --ap;

     
    if (*n == 0) {
	value = 0.;
    } else if (lsame_(norm, "M", 1L, 1L)) {

 

	value = 0.;
	if (lsame_(uplo, "U", 1L, 1L)) {
	    k = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = k + j - 1;
		for (i__ = k; i__ <= i__2; ++i__) {
 
		    d__2 = value, d__3 = (d__1 = ap[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		}
		k += j;
 
	    }
	} else {
	    k = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = k + *n - j;
		for (i__ = k; i__ <= i__2; ++i__) {
 
		    d__2 = value, d__3 = (d__1 = ap[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		}
		k = k + *n - j + 1;
 
	    }
	}
    } else if (lsame_(norm, "I", 1L, 1L) || lsame_(norm, "O", 1L, 1L) || *(
	    unsigned char *)norm == '1') {

 

	value = 0.;
	k = 1;
	if (lsame_(uplo, "U", 1L, 1L)) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		sum = 0.;
		i__2 = j - 1;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    sum += absa;
		    work[i__] += absa;
		    ++k;
 
		}
		work[j] = sum + (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		++k;
 
	    }
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__1 = value, d__2 = work[i__];
		value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	    }
	} else {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		work[i__] = 0.;
 
	    }
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		sum = work[j] + (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		++k;
		i__2 = *n;
		for (i__ = j + 1; i__ <= i__2; ++i__) {
		    absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    sum += absa;
		    work[i__] += absa;
		    ++k;
 
		}
		value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ;
 
	    }
	}
    } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {

 

	scale = 0.;
	sum = 1.;
	k = 2;
	if (lsame_(uplo, "U", 1L, 1L)) {
	    i__1 = *n;
	    for (j = 2; j <= i__1; ++j) {
		i__2 = j - 1;
		dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
		k += j;
 
	    }
	} else {
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n - j;
		dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
		k = k + *n - j + 1;
 
	    }
	}
	sum *= 2;
	k = 1;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (ap[k] != 0.) {
		absa = (d__1 = ap[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (scale < absa) {
 
		    d__1 = scale / absa;
		    sum = sum * (d__1 * d__1) + 1.;
		    scale = absa;
		} else {
 
		    d__1 = absa / scale;
		    sum += d__1 * d__1;
		}
	    }
	    if (lsame_(uplo, "U", 1L, 1L)) {
		k = k + i__ + 1;
	    } else {
		k = k + *n - i__ + 1;
	    }
 
	}
	value = scale * sqrt(sum);
    }

    ret_val = value;
    return ret_val;

 

}  

doublereal dlanst_(norm, n, d__, e, norm_len)
char *norm;
integer *n;
doublereal *d__, *e;
ftnlen norm_len;
{
     
    integer i__1;
    doublereal ret_val, d__1, d__2, d__3, d__4, d__5;

     
    double sqrt();

     
    static integer i__;
    static doublereal scale;
    extern logical lsame_();
    static doublereal anorm;
    extern   int dlassq_();
    static doublereal sum;
     
    --e;
    --d__;

     
    if (*n <= 0) {
	anorm = 0.;
    } else if (lsame_(norm, "M", 1L, 1L)) {

 

	anorm = (d__1 = d__[*n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	i__1 = *n - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__2 = anorm, d__3 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    anorm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	    d__2 = anorm, d__3 = (d__1 = e[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    anorm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	}
    } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1' || 
	    lsame_(norm, "I", 1L, 1L)) {

 

	if (*n == 1) {
	    anorm = (( d__[1] ) >= 0 ? ( d__[1] ) : -( d__[1] )) ;
	} else {
 
	    d__3 = (( d__[1] ) >= 0 ? ( d__[1] ) : -( d__[1] ))  + (( e[1] ) >= 0 ? ( e[1] ) : -( e[1] )) , d__4 = (d__1 = e[*n - 1], (( 
		    d__1 ) >= 0 ? (  		    d__1 ) : -(  		    d__1 )) ) + (d__2 = d__[*n], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) );
	    anorm = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
	    i__1 = *n - 1;
	    for (i__ = 2; i__ <= i__1; ++i__) {
 
		d__4 = anorm, d__5 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = e[
			i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + (d__3 = e[i__ - 1], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) );
		anorm = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ;
 
	    }
	}
    } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {

 

	scale = 0.;
	sum = 1.;
	if (*n > 1) {
	    i__1 = *n - 1;
	    dlassq_(&i__1, &e[1], &c__1, &scale, &sum);
	    sum *= 2;
	}
	dlassq_(n, &d__[1], &c__1, &scale, &sum);
	anorm = scale * sqrt(sum);
    }

    ret_val = anorm;
    return ret_val;

 

}  

doublereal dlantr_(norm, uplo, diag, m, n, a, lda, work, norm_len, uplo_len, 
	diag_len)
char *norm, *uplo, *diag;
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
ftnlen uplo_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
    doublereal ret_val, d__1, d__2, d__3;

     
    double sqrt();

     
    static integer i__, j;
    static doublereal scale;
    static logical udiag;
    extern logical lsame_();
    static doublereal value;
    extern   int dlassq_();
    static doublereal sum;

     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --work;

     
    if ((( *m ) <= ( *n ) ? ( *m ) : ( *n ))  == 0) {
	value = 0.;
    } else if (lsame_(norm, "M", 1L, 1L)) {

 

	if (lsame_(diag, "U", 1L, 1L)) {
	    value = 1.;
	    if (lsame_(uplo, "U", 1L, 1L)) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
 
		    i__3 = *m, i__4 = j - 1;
		    i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
		    for (i__ = 1; i__ <= i__2; ++i__) {
 
			d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( 
				d__1 ) >= 0 ? (  				d__1 ) : -(  				d__1 )) );
			value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
 
			d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( 
				d__1 ) >= 0 ? (  				d__1 ) : -(  				d__1 )) );
			value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		    }
 
		}
	    }
	} else {
	    value = 0.;
	    if (lsame_(uplo, "U", 1L, 1L)) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ;
		    for (i__ = 1; i__ <= i__2; ++i__) {
 
			d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( 
				d__1 ) >= 0 ? (  				d__1 ) : -(  				d__1 )) );
			value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = j; i__ <= i__2; ++i__) {
 
			d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], (( 
				d__1 ) >= 0 ? (  				d__1 ) : -(  				d__1 )) );
			value = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
		    }
 
		}
	    }
	}
    } else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {

 

	value = 0.;
	udiag = lsame_(diag, "U", 1L, 1L);
	if (lsame_(uplo, "U", 1L, 1L)) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (udiag && j <= *m) {
		    sum = 1.;
		    i__2 = j - 1;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
		} else {
		    sum = 0.;
		    i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
		}
		value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ;
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (udiag) {
		    sum = 1.;
		    i__2 = *m;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
			sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
		} else {
		    sum = 0.;
		    i__2 = *m;
		    for (i__ = j; i__ <= i__2; ++i__) {
			sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
		}
		value = (( value ) >= ( sum ) ? ( value ) : ( sum )) ;
 
	    }
	}
    } else if (lsame_(norm, "I", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (lsame_(diag, "U", 1L, 1L)) {
		i__1 = *m;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    work[i__] = 1.;
 
		}
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
 
		    i__3 = *m, i__4 = j - 1;
		    i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
 
		}
	    } else {
		i__1 = *m;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    work[i__] = 0.;
 
		}
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
 
		}
	    }
	} else {
	    if (lsame_(diag, "U", 1L, 1L)) {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    work[i__] = 1.;
 
		}
		i__1 = *m;
		for (i__ = *n + 1; i__ <= i__1; ++i__) {
		    work[i__] = 0.;
 
		}
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
			work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
 
		}
	    } else {
		i__1 = *m;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    work[i__] = 0.;
 
		}
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = j; i__ <= i__2; ++i__) {
			work[i__] += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		    }
 
		}
	    }
	}
	value = 0.;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__1 = value, d__2 = work[i__];
	    value = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	}
    } else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (lsame_(diag, "U", 1L, 1L)) {
		scale = 1.;
		sum = (doublereal) (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
		i__1 = *n;
		for (j = 2; j <= i__1; ++j) {
 
		    i__3 = *m, i__4 = j - 1;
		    i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
		    dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
 
		}
	    } else {
		scale = 0.;
		sum = 1.;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = (( *m ) <= ( j ) ? ( *m ) : ( j )) ;
		    dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
 
		}
	    }
	} else {
	    if (lsame_(diag, "U", 1L, 1L)) {
		scale = 1.;
		sum = (doublereal) (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m - j;
 
		    i__3 = *m, i__4 = j + 1;
		    dlassq_(&i__2, &a[(( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 ))  + j * a_dim1], &c__1, &
			    scale, &sum);
 
		}
	    } else {
		scale = 0.;
		sum = 1.;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m - j + 1;
		    dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
 
		}
	    }
	}
	value = scale * sqrt(sum);
    }

    ret_val = value;
    return ret_val;

 

}  

doublereal dlapy2_(x, y)
doublereal *x, *y;
{
     
    doublereal ret_val, d__1;

     
    double sqrt();

     
    static doublereal xabs, yabs, w, z__;

    xabs = (( *x ) >= 0 ? ( *x ) : -( *x )) ;
    yabs = (( *y ) >= 0 ? ( *y ) : -( *y )) ;
    w = (( xabs ) >= ( yabs ) ? ( xabs ) : ( yabs )) ;
    z__ = (( xabs ) <= ( yabs ) ? ( xabs ) : ( yabs )) ;
    if (z__ == 0.) {
	ret_val = w;
    } else {
 
	d__1 = z__ / w;
	ret_val = w * sqrt(d__1 * d__1 + 1.);
    }
    return ret_val;

 

}  

  int dlarf_(side, m, n, v, incv, tau, c__, ldc, work, 
	side_len)
char *side;
integer *m, *n;
doublereal *v;
integer *incv;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
ftnlen side_len;
{
     
    integer c_dim1, c_offset;
    doublereal d__1;

     
    extern   int dger_();
    extern logical lsame_();
    extern   int dgemv_();

     
    --v;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --work;

     
    if (lsame_(side, "L", 1L, 1L)) {

 

	if (*tau != 0.) {

 

	    dgemv_("Transpose", m, n, &c_b89, &c__[c_offset], ldc, &v[1], 
		    incv, &c_b61, &work[1], &c__1, 9L);

 

	    d__1 = -(*tau);
	    dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], 
		    ldc);
	}
    } else {

 

	if (*tau != 0.) {

 

	    dgemv_("No transpose", m, n, &c_b89, &c__[c_offset], ldc, &v[1], 
		    incv, &c_b61, &work[1], &c__1, 12L);

 

	    d__1 = -(*tau);
	    dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], 
		    ldc);
	}
    }
    return 0;

 

}  

  int dlarfb_(side, trans, direct, storev, m, n, k, v, ldv, t, 
	ldt, c__, ldc, work, ldwork, side_len, trans_len, direct_len, 
	storev_len)
char *side, *trans, *direct, *storev;
integer *m, *n, *k;
doublereal *v;
integer *ldv;
doublereal *t;
integer *ldt;
doublereal *c__;
integer *ldc;
doublereal *work;
integer *ldwork;
ftnlen side_len;
ftnlen trans_len;
ftnlen direct_len;
ftnlen storev_len;
{
     
    integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, 
	    work_offset, i__1, i__2;

     
    static integer i__, j;
    extern   int dgemm_();
    extern logical lsame_();
    extern   int dcopy_(), dtrmm_();
    static char transt[1];

     
    v_dim1 = *ldv;
    v_offset = v_dim1 + 1;
    v -= v_offset;
    t_dim1 = *ldt;
    t_offset = t_dim1 + 1;
    t -= t_offset;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    work_dim1 = *ldwork;
    work_offset = work_dim1 + 1;
    work -= work_offset;

     
    if (*m <= 0 || *n <= 0) {
	return 0;
    }

    if (lsame_(trans, "N", 1L, 1L)) {
	*(unsigned char *)transt = 'T';
    } else {
	*(unsigned char *)transt = 'N';
    }

    if (lsame_(storev, "C", 1L, 1L)) {

	if (lsame_(direct, "F", 1L, 1L)) {

 
 
 

	    if (lsame_(side, "L", 1L, 1L)) {

 
 

 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
			     &c__1);
 
		}

 

		dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b89,
			 &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 
			5L, 12L, 4L);
		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b89, &
			    c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], 
			    ldv, &c_b89, &work[work_offset], ldwork, 9L, 12L);
		}

 

		dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b418, 
			    &v[*k + 1 + v_dim1], ldv, &work[work_offset], 
			    ldwork, &c_b89, &c__[*k + 1 + c_dim1], ldc, 12L, 
			    9L);
		}

 

		dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b89, &
			v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 
			9L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
 
		    }
 
		}

	    } else if (lsame_(side, "R", 1L, 1L)) {

 


 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * 
			    work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b89,
			 &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 
			5L, 12L, 4L);
		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "No transpose", m, k, &i__1, &
			    c_b89, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 
			    1 + v_dim1], ldv, &c_b89, &work[work_offset], 
			    ldwork, 12L, 12L);
		}

 

		dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b418, 
			    &work[work_offset], ldwork, &v[*k + 1 + v_dim1], 
			    ldv, &c_b89, &c__[(*k + 1) * c_dim1 + 1], ldc, 
			    12L, 9L);
		}

 

		dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b89, &
			v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 
			9L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
 
		    }
 
		}
	    }

	} else {

 
 
 

	    if (lsame_(side, "L", 1L, 1L)) {

 
 

 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * 
			    work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b89,
			 &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], 
			ldwork, 5L, 5L, 12L, 4L);
		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b89, &
			    c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, &
			    work[work_offset], ldwork, 9L, 12L);
		}

 

		dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b418, 
			    &v[v_offset], ldv, &work[work_offset], ldwork, &
			    c_b89, &c__[c_offset], ldc, 12L, 9L);
		}

 

		dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b89, &
			v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], 
			ldwork, 5L, 5L, 9L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * 
				work_dim1];
 
		    }
 
		}

	    } else if (lsame_(side, "R", 1L, 1L)) {

 


 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
			    j * work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b89,
			 &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], 
			ldwork, 5L, 5L, 12L, 4L);
		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "No transpose", m, k, &i__1, &
			    c_b89, &c__[c_offset], ldc, &v[v_offset], ldv, &
			    c_b89, &work[work_offset], ldwork, 12L, 12L);
		}

 

		dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b418, 
			    &work[work_offset], ldwork, &v[v_offset], ldv, &
			    c_b89, &c__[c_offset], ldc, 12L, 9L);
		}

 

		dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b89, &
			v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], 
			ldwork, 5L, 5L, 9L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * 
				work_dim1];
 
		    }
 
		}
	    }
	}

    } else if (lsame_(storev, "R", 1L, 1L)) {

	if (lsame_(direct, "F", 1L, 1L)) {

 
 

	    if (lsame_(side, "L", 1L, 1L)) {

 
 

 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
			     &c__1);
 
		}

 

		dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b89, &
			v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 
			9L, 4L);
		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b89, &
			    c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + 
			    1], ldv, &c_b89, &work[work_offset], ldwork, 9L, 
			    9L);
		}

 

		dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b418, &v[
			    (*k + 1) * v_dim1 + 1], ldv, &work[work_offset], 
			    ldwork, &c_b89, &c__[*k + 1 + c_dim1], ldc, 9L, 
			    9L);
		}

 

		dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b89,
			 &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 
			5L, 12L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
 
		    }
 
		}

	    } else if (lsame_(side, "R", 1L, 1L)) {

 


 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * 
			    work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b89, &
			v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L, 
			9L, 4L);
		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b89, &
			    c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * 
			    v_dim1 + 1], ldv, &c_b89, &work[work_offset], 
			    ldwork, 12L, 9L);
		}

 

		dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "No transpose", m, &i__1, k, &
			    c_b418, &work[work_offset], ldwork, &v[(*k + 1) * 
			    v_dim1 + 1], ldv, &c_b89, &c__[(*k + 1) * c_dim1 
			    + 1], ldc, 12L, 12L);
		}

 

		dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b89,
			 &v[v_offset], ldv, &work[work_offset], ldwork, 5L, 
			5L, 12L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
 
		    }
 
		}

	    }

	} else {

 
 

	    if (lsame_(side, "L", 1L, 1L)) {

 
 

 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * 
			    work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b89, &
			v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
			, ldwork, 5L, 5L, 9L, 4L);
		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b89, &
			    c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, &
			    work[work_offset], ldwork, 9L, 9L);
		}

 

		dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*m > *k) {

 

		    i__1 = *m - *k;
		    dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b418, &v[
			    v_offset], ldv, &work[work_offset], ldwork, &
			    c_b89, &c__[c_offset], ldc, 9L, 9L);
		}

 

		dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b89,
			 &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
			work_offset], ldwork, 5L, 5L, 12L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * 
				work_dim1];
 
		    }
 
		}

	    } else if (lsame_(side, "R", 1L, 1L)) {

 


 


 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
			    j * work_dim1 + 1], &c__1);
 
		}

 

		dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b89, &
			v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
			, ldwork, 5L, 5L, 9L, 4L);
		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b89, &
			    c__[c_offset], ldc, &v[v_offset], ldv, &c_b89, &
			    work[work_offset], ldwork, 12L, 9L);
		}

 

		dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b89, &t[
			t_offset], ldt, &work[work_offset], ldwork, 5L, 5L, 
			1L, 8L);

 

		if (*n > *k) {

 

		    i__1 = *n - *k;
		    dgemm_("No transpose", "No transpose", m, &i__1, k, &
			    c_b418, &work[work_offset], ldwork, &v[v_offset], 
			    ldv, &c_b89, &c__[c_offset], ldc, 12L, 12L);
		}

 

		dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b89,
			 &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
			work_offset], ldwork, 5L, 5L, 12L, 4L);

 

		i__1 = *k;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * 
				work_dim1];
 
		    }
 
		}

	    }

	}
    }

    return 0;

 

}  

  int dlarfg_(n, alpha, x, incx, tau)
integer *n;
doublereal *alpha, *x;
integer *incx;
doublereal *tau;
{
     
    integer i__1;
    doublereal d__1;

     
    double d_sign();

     
    static doublereal beta;
    extern doublereal dnrm2_();
    static integer j;
    extern   int dscal_();
    static doublereal xnorm;
    extern doublereal dlapy2_(), dlamch_();
    static doublereal safmin, rsafmn;
    static integer knt;
     
    --x;

     
    if (*n <= 1) {
	*tau = 0.;
	return 0;
    }

    i__1 = *n - 1;
    xnorm = dnrm2_(&i__1, &x[1], incx);

    if (xnorm == 0.) {

 

	*tau = 0.;
    } else {

 

	d__1 = dlapy2_(alpha, &xnorm);
	beta = -d_sign(&d__1, alpha);
	safmin = dlamch_("S", 1L) / dlamch_("E", 1L);
	if ((( beta ) >= 0 ? ( beta ) : -( beta ))  < safmin) {

 


	    rsafmn = 1. / safmin;
	    knt = 0;
L10:
	    ++knt;
	    i__1 = *n - 1;
	    dscal_(&i__1, &rsafmn, &x[1], incx);
	    beta *= rsafmn;
	    *alpha *= rsafmn;
	    if ((( beta ) >= 0 ? ( beta ) : -( beta ))  < safmin) {
		goto L10;
	    }

 

	    i__1 = *n - 1;
	    xnorm = dnrm2_(&i__1, &x[1], incx);
	    d__1 = dlapy2_(alpha, &xnorm);
	    beta = -d_sign(&d__1, alpha);
	    *tau = (beta - *alpha) / beta;
	    i__1 = *n - 1;
	    d__1 = 1. / (*alpha - beta);
	    dscal_(&i__1, &d__1, &x[1], incx);

 


	    *alpha = beta;
	    i__1 = knt;
	    for (j = 1; j <= i__1; ++j) {
		*alpha *= safmin;
 
	    }
	} else {
	    *tau = (beta - *alpha) / beta;
	    i__1 = *n - 1;
	    d__1 = 1. / (*alpha - beta);
	    dscal_(&i__1, &d__1, &x[1], incx);
	    *alpha = beta;
	}
    }

    return 0;

 

}  

  int dlarft_(direct, storev, n, k, v, ldv, tau, t, ldt, 
	direct_len, storev_len)
char *direct, *storev;
integer *n, *k;
doublereal *v;
integer *ldv;
doublereal *tau, *t;
integer *ldt;
ftnlen direct_len;
ftnlen storev_len;
{
     
    integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
    doublereal d__1;

     
    static integer i__, j;
    extern logical lsame_();
    extern   int dgemv_(), dtrmv_();
    static doublereal vii;
     
    v_dim1 = *ldv;
    v_offset = v_dim1 + 1;
    v -= v_offset;
    --tau;
    t_dim1 = *ldt;
    t_offset = t_dim1 + 1;
    t -= t_offset;

     
    if (*n == 0) {
	return 0;
    }

    if (lsame_(direct, "F", 1L, 1L)) {
	i__1 = *k;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (tau[i__] == 0.) {

 

		i__2 = i__;
		for (j = 1; j <= i__2; ++j) {
		    t[j + i__ * t_dim1] = 0.;
 
		}
	    } else {

 

		vii = v[i__ + i__ * v_dim1];
		v[i__ + i__ * v_dim1] = 1.;
		if (lsame_(storev, "C", 1L, 1L)) {

 


		    i__2 = *n - i__ + 1;
		    i__3 = i__ - 1;
		    d__1 = -tau[i__];
		    dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1],
			     ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b61, &t[
			    i__ * t_dim1 + 1], &c__1, 9L);
		} else {

 


		    i__2 = i__ - 1;
		    i__3 = *n - i__ + 1;
		    d__1 = -tau[i__];
		    dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * 
			    v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
			    c_b61, &t[i__ * t_dim1 + 1], &c__1, 12L);
		}
		v[i__ + i__ * v_dim1] = vii;

 

		i__2 = i__ - 1;
		dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
			t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 
			8L);
		t[i__ + i__ * t_dim1] = tau[i__];
	    }
 
	}
    } else {
	for (i__ = *k; i__ >= 1; --i__) {
	    if (tau[i__] == 0.) {

 

		i__1 = *k;
		for (j = i__; j <= i__1; ++j) {
		    t[j + i__ * t_dim1] = 0.;
 
		}
	    } else {

 

		if (i__ < *k) {
		    if (lsame_(storev, "C", 1L, 1L)) {
			vii = v[*n - *k + i__ + i__ * v_dim1];
			v[*n - *k + i__ + i__ * v_dim1] = 1.;

 
 


			i__1 = *n - *k + i__;
			i__2 = *k - i__;
			d__1 = -tau[i__];
			dgemv_("Transpose", &i__1, &i__2, &d__1, &v[(i__ + 1) 
				* v_dim1 + 1], ldv, &v[i__ * v_dim1 + 1], &
				c__1, &c_b61, &t[i__ + 1 + i__ * t_dim1], &
				c__1, 9L);
			v[*n - *k + i__ + i__ * v_dim1] = vii;
		    } else {
			vii = v[i__ + (*n - *k + i__) * v_dim1];
			v[i__ + (*n - *k + i__) * v_dim1] = 1.;

 
 


			i__1 = *k - i__;
			i__2 = *n - *k + i__;
			d__1 = -tau[i__];
			dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + 
				1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
				c_b61, &t[i__ + 1 + i__ * t_dim1], &c__1, 12L)
				;
			v[i__ + (*n - *k + i__) * v_dim1] = vii;
		    }

 


		    i__1 = *k - i__;
		    dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ 
			    + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
			     t_dim1], &c__1, 5L, 12L, 8L);
		}
		t[i__ + i__ * t_dim1] = tau[i__];
	    }
 
	}
    }
    return 0;

 

}  

  int dlartg_(f, g, cs, sn, r__)
doublereal *f, *g, *cs, *sn, *r__;
{
     

    static logical first = (1) ;

     
    integer i__1;
    doublereal d__1, d__2;

     
    double log(), pow_di(), sqrt();

     
    static integer i__;
    static doublereal scale;
    static integer count;
    static doublereal f1, g1, safmn2, safmx2;
    extern doublereal dlamch_();
    static doublereal safmin, eps;

    if (first) {
	first = (0) ;
	safmin = dlamch_("S", 1L);
	eps = dlamch_("E", 1L);
	d__1 = dlamch_("B", 1L);
	i__1 = (integer) (log(safmin / eps) / log(dlamch_("B", 1L)) / 2.);
	safmn2 = pow_di(&d__1, &i__1);
	safmx2 = 1. / safmn2;
    }
    if (*g == 0.) {
	*cs = 1.;
	*sn = 0.;
	*r__ = *f;
    } else if (*f == 0.) {
	*cs = 0.;
	*sn = 1.;
	*r__ = *g;
    } else {
	f1 = *f;
	g1 = *g;
 
	d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ;
	scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	if (scale >= safmx2) {
	    count = 0;
L10:
	    ++count;
	    f1 *= safmn2;
	    g1 *= safmn2;
 
	    d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ;
	    scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    if (scale >= safmx2) {
		goto L10;
	    }
 
	    d__1 = f1;
 
	    d__2 = g1;
	    *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
	    *cs = f1 / *r__;
	    *sn = g1 / *r__;
	    i__1 = count;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		*r__ *= safmx2;
 
	    }
	} else if (scale <= safmn2) {
	    count = 0;
L30:
	    ++count;
	    f1 *= safmx2;
	    g1 *= safmx2;
 
	    d__1 = (( f1 ) >= 0 ? ( f1 ) : -( f1 )) , d__2 = (( g1 ) >= 0 ? ( g1 ) : -( g1 )) ;
	    scale = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    if (scale <= safmn2) {
		goto L30;
	    }
 
	    d__1 = f1;
 
	    d__2 = g1;
	    *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
	    *cs = f1 / *r__;
	    *sn = g1 / *r__;
	    i__1 = count;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		*r__ *= safmn2;
 
	    }
	} else {
 
	    d__1 = f1;
 
	    d__2 = g1;
	    *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
	    *cs = f1 / *r__;
	    *sn = g1 / *r__;
	}
	if ((( *f ) >= 0 ? ( *f ) : -( *f ))  > (( *g ) >= 0 ? ( *g ) : -( *g ))  && *cs < 0.) {
	    *cs = -(*cs);
	    *sn = -(*sn);
	    *r__ = -(*r__);
	}
    }
    return 0;

 

}  

  int dlascl_(type__, kl, ku, cfrom, cto, m, n, a, lda, info, 
	type_len)
char *type__;
integer *kl, *ku;
doublereal *cfrom, *cto;
integer *m, *n;
doublereal *a;
integer *lda, *info;
ftnlen type_len;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;

     
    static logical done;
    static doublereal ctoc;
    static integer i__, j;
    extern logical lsame_();
    static integer itype, k1, k2, k3, k4;
    static doublereal cfrom1;
    extern doublereal dlamch_();
    static doublereal cfromc;
    extern   int xerbla_();
    static doublereal bignum, smlnum, mul, cto1;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    *info = 0;

    if (lsame_(type__, "G", 1L, 1L)) {
	itype = 0;
    } else if (lsame_(type__, "L", 1L, 1L)) {
	itype = 1;
    } else if (lsame_(type__, "U", 1L, 1L)) {
	itype = 2;
    } else if (lsame_(type__, "H", 1L, 1L)) {
	itype = 3;
    } else if (lsame_(type__, "B", 1L, 1L)) {
	itype = 4;
    } else if (lsame_(type__, "Q", 1L, 1L)) {
	itype = 5;
    } else if (lsame_(type__, "Z", 1L, 1L)) {
	itype = 6;
    } else {
	itype = -1;
    }

    if (itype == -1) {
	*info = -1;
    } else if (*cfrom == 0.) {
	*info = -4;
    } else if (*m < 0) {
	*info = -6;
    } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
	*info = -7;
    } else if (itype <= 3 && *lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -9;
    } else if (itype >= 4) {
 
	i__1 = *m - 1;
	if (*kl < 0 || *kl > (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ) {
	    *info = -2;
	} else   {
 
	    i__1 = *n - 1;
	    if (*ku < 0 || *ku > (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 ))  || (itype == 4 || itype == 5) && 
		    *kl != *ku) {
		*info = -3;
	    } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
		    ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
		*info = -9;
	    }
	}
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DLASCL", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0 || *m == 0) {
	return 0;
    }

 

    smlnum = dlamch_("S", 1L);
    bignum = 1. / smlnum;

    cfromc = *cfrom;
    ctoc = *cto;

L10:
    cfrom1 = cfromc * smlnum;
    cto1 = ctoc / bignum;
    if ((( cfrom1 ) >= 0 ? ( cfrom1 ) : -( cfrom1 ))  > (( ctoc ) >= 0 ? ( ctoc ) : -( ctoc ))  && ctoc != 0.) {
	mul = smlnum;
	done = (0) ;
	cfromc = cfrom1;
    } else if ((( cto1 ) >= 0 ? ( cto1 ) : -( cto1 ))  > (( cfromc ) >= 0 ? ( cfromc ) : -( cfromc )) ) {
	mul = bignum;
	done = (0) ;
	ctoc = cto1;
    } else {
	mul = ctoc / cfromc;
	done = (1) ;
    }

    if (itype == 0) {

 

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 1) {

 

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = j; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 2) {

 

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = (( j ) <= ( *m ) ? ( j ) : ( *m )) ;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 3) {

 

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
 
	    i__3 = j + 1;
	    i__2 = (( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m )) ;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 4) {

 

	k3 = *kl + 1;
	k4 = *n + 1;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
 
	    i__3 = k3, i__4 = k4 - j;
	    i__2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 5) {

 

	k1 = *ku + 2;
	k3 = *ku + 1;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
 
	    i__2 = k1 - j;
	    i__3 = k3;
	    for (i__ = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ; i__ <= i__3; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    } else if (itype == 6) {

 

	k1 = *kl + *ku + 2;
	k2 = *kl + 1;
	k3 = (*kl << 1) + *ku + 1;
	k4 = *kl + *ku + 1 + *m;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
 
	    i__3 = k1 - j;
 
	    i__4 = k3, i__5 = k4 - j;
	    i__2 = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;
	    for (i__ = (( i__3 ) >= ( k2 ) ? ( i__3 ) : ( k2 )) ; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] *= mul;
 
	    }
 
	}

    }

    if (! done) {
	goto L10;
    }

    return 0;

 

}  

  int dlaset_(uplo, m, n, alpha, beta, a, lda, uplo_len)
char *uplo;
integer *m, *n;
doublereal *alpha, *beta, *a;
integer *lda;
ftnlen uplo_len;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3;

     
    static integer i__, j;
    extern logical lsame_();
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    if (lsame_(uplo, "U", 1L, 1L)) {

 

 

	i__1 = *n;
	for (j = 2; j <= i__1; ++j) {
 
	    i__3 = j - 1;
	    i__2 = (( i__3 ) <= ( *m ) ? ( i__3 ) : ( *m )) ;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] = *alpha;
 
	    }
 
	}

    } else if (lsame_(uplo, "L", 1L, 1L)) {

 

 

	i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = j + 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] = *alpha;
 
	    }
 
	}

    } else {

 

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		a[i__ + j * a_dim1] = *alpha;
 
	    }
 
	}
    }

 

    i__1 = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    for (i__ = 1; i__ <= i__1; ++i__) {
	a[i__ + i__ * a_dim1] = *beta;
 
    }

    return 0;

 

}  

  int dlasr_(side, pivot, direct, m, n, c__, s, a, lda, 
	side_len, pivot_len, direct_len)
char *side, *pivot, *direct;
integer *m, *n;
doublereal *c__, *s, *a;
integer *lda;
ftnlen side_len;
ftnlen pivot_len;
ftnlen direct_len;
{
     
    integer a_dim1, a_offset, i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j;
    extern logical lsame_();
    static doublereal ctemp, stemp;
    extern   int xerbla_();
     
    --c__;
    --s;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    info = 0;
    if (! (lsame_(side, "L", 1L, 1L) || lsame_(side, "R", 1L, 1L))) {
	info = 1;
    } else if (! (lsame_(pivot, "V", 1L, 1L) || lsame_(pivot, "T", 1L, 1L) || 
	    lsame_(pivot, "B", 1L, 1L))) {
	info = 2;
    } else if (! (lsame_(direct, "F", 1L, 1L) || lsame_(direct, "B", 1L, 1L)))
	     {
	info = 3;
    } else if (*m < 0) {
	info = 4;
    } else if (*n < 0) {
	info = 5;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 9;
    }
    if (info != 0) {
	xerbla_("DLASR ", &info, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0) {
	return 0;
    }
    if (lsame_(side, "L", 1L, 1L)) {

 

	if (lsame_(pivot, "V", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *m - 1;
		for (j = 1; j <= i__1; ++j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *n;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[j + 1 + i__ * a_dim1];
			    a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * 
				    a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j 
				    + i__ * a_dim1];
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *m - 1; j >= 1; --j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *n;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[j + 1 + i__ * a_dim1];
			    a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * 
				    a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j 
				    + i__ * a_dim1];
 
			}
		    }
 
		}
	    }
	} else if (lsame_(pivot, "T", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *m;
		for (j = 2; j <= i__1; ++j) {
		    ctemp = c__[j - 1];
		    stemp = s[j - 1];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *n;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
				    i__ * a_dim1 + 1];
			    a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
				    i__ * a_dim1 + 1];
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *m; j >= 2; --j) {
		    ctemp = c__[j - 1];
		    stemp = s[j - 1];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *n;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
				    i__ * a_dim1 + 1];
			    a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
				    i__ * a_dim1 + 1];
 
			}
		    }
 
		}
	    }
	} else if (lsame_(pivot, "B", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *m - 1;
		for (j = 1; j <= i__1; ++j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *n;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
				     + ctemp * temp;
			    a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * 
				    a_dim1] - stemp * temp;
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *m - 1; j >= 1; --j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *n;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[j + i__ * a_dim1];
			    a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
				     + ctemp * temp;
			    a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * 
				    a_dim1] - stemp * temp;
 
			}
		    }
 
		}
	    }
	}
    } else if (lsame_(side, "R", 1L, 1L)) {

 

	if (lsame_(pivot, "V", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *n - 1;
		for (j = 1; j <= i__1; ++j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[i__ + (j + 1) * a_dim1];
			    a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
				     a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
				    i__ + j * a_dim1];
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *n - 1; j >= 1; --j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[i__ + (j + 1) * a_dim1];
			    a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
				     a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
				    i__ + j * a_dim1];
 
			}
		    }
 
		}
	    }
	} else if (lsame_(pivot, "T", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *n;
		for (j = 2; j <= i__1; ++j) {
		    ctemp = c__[j - 1];
		    stemp = s[j - 1];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
				    i__ + a_dim1];
			    a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + 
				    a_dim1];
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *n; j >= 2; --j) {
		    ctemp = c__[j - 1];
		    stemp = s[j - 1];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
				    i__ + a_dim1];
			    a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + 
				    a_dim1];
 
			}
		    }
 
		}
	    }
	} else if (lsame_(pivot, "B", 1L, 1L)) {
	    if (lsame_(direct, "F", 1L, 1L)) {
		i__1 = *n - 1;
		for (j = 1; j <= i__1; ++j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    temp = a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
				     + ctemp * temp;
			    a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * 
				    a_dim1] - stemp * temp;
 
			}
		    }
 
		}
	    } else if (lsame_(direct, "B", 1L, 1L)) {
		for (j = *n - 1; j >= 1; --j) {
		    ctemp = c__[j];
		    stemp = s[j];
		    if (ctemp != 1. || stemp != 0.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    temp = a[i__ + j * a_dim1];
			    a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
				     + ctemp * temp;
			    a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * 
				    a_dim1] - stemp * temp;
 
			}
		    }
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dlasrt_(id, n, d__, info, id_len)
char *id;
integer *n;
doublereal *d__;
integer *info;
ftnlen id_len;
{
     
    integer i__1, i__2;

     
    static integer endd, i__, j;
    extern logical lsame_();
    static integer stack[64]	 ;
    static doublereal dmnmx, d1, d2, d3;
    static integer start;
    extern   int xerbla_();
    static integer stkpnt, dir;
    static doublereal tmp;
     
    --d__;

     
    *info = 0;
    dir = -1;
    if (lsame_(id, "D", 1L, 1L)) {
	dir = 0;
    } else if (lsame_(id, "I", 1L, 1L)) {
	dir = 1;
    }
    if (dir == -1) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DLASRT", &i__1, 6L);
	return 0;
    }

 

    if (*n <= 1) {
	return 0;
    }

    stkpnt = 1;
    stack[0] = 1;
    stack[1] = *n;
L10:
    start = stack[(stkpnt << 1) - 2];
    endd = stack[(stkpnt << 1) - 1];
    --stkpnt;
    if (endd - start <= 20 && endd - start > 0) {

 

	if (dir == 0) {

 

	    i__1 = endd;
	    for (i__ = start + 1; i__ <= i__1; ++i__) {
		i__2 = start + 1;
		for (j = i__; j >= i__2; --j) {
		    if (d__[j] > d__[j - 1]) {
			dmnmx = d__[j];
			d__[j] = d__[j - 1];
			d__[j - 1] = dmnmx;
		    } else {
			goto L30;
		    }
 
		}
L30:
		;
	    }

	} else {

 

	    i__1 = endd;
	    for (i__ = start + 1; i__ <= i__1; ++i__) {
		i__2 = start + 1;
		for (j = i__; j >= i__2; --j) {
		    if (d__[j] < d__[j - 1]) {
			dmnmx = d__[j];
			d__[j] = d__[j - 1];
			d__[j - 1] = dmnmx;
		    } else {
			goto L50;
		    }
 
		}
L50:
		;
	    }

	}

    } else if (endd - start > 20) {

 


 

	d1 = d__[start];
	d2 = d__[endd];
	i__ = (start + endd) / 2;
	d3 = d__[i__];
	if (d1 < d2) {
	    if (d3 < d1) {
		dmnmx = d1;
	    } else if (d3 < d2) {
		dmnmx = d3;
	    } else {
		dmnmx = d2;
	    }
	} else {
	    if (d3 < d2) {
		dmnmx = d2;
	    } else if (d3 < d1) {
		dmnmx = d3;
	    } else {
		dmnmx = d1;
	    }
	}

	if (dir == 0) {

 

	    i__ = start - 1;
	    j = endd + 1;
L60:
L70:
	    --j;
	    if (d__[j] < dmnmx) {
		goto L70;
	    }
L80:
	    ++i__;
	    if (d__[i__] > dmnmx) {
		goto L80;
	    }
	    if (i__ < j) {
		tmp = d__[i__];
		d__[i__] = d__[j];
		d__[j] = tmp;
		goto L60;
	    }
	    if (j - start > endd - j - 1) {
		++stkpnt;
		stack[(stkpnt << 1) - 2] = start;
		stack[(stkpnt << 1) - 1] = j;
		++stkpnt;
		stack[(stkpnt << 1) - 2] = j + 1;
		stack[(stkpnt << 1) - 1] = endd;
	    } else {
		++stkpnt;
		stack[(stkpnt << 1) - 2] = j + 1;
		stack[(stkpnt << 1) - 1] = endd;
		++stkpnt;
		stack[(stkpnt << 1) - 2] = start;
		stack[(stkpnt << 1) - 1] = j;
	    }
	} else {

 

	    i__ = start - 1;
	    j = endd + 1;
L90:
L100:
	    --j;
	    if (d__[j] > dmnmx) {
		goto L100;
	    }
L110:
	    ++i__;
	    if (d__[i__] < dmnmx) {
		goto L110;
	    }
	    if (i__ < j) {
		tmp = d__[i__];
		d__[i__] = d__[j];
		d__[j] = tmp;
		goto L90;
	    }
	    if (j - start > endd - j - 1) {
		++stkpnt;
		stack[(stkpnt << 1) - 2] = start;
		stack[(stkpnt << 1) - 1] = j;
		++stkpnt;
		stack[(stkpnt << 1) - 2] = j + 1;
		stack[(stkpnt << 1) - 1] = endd;
	    } else {
		++stkpnt;
		stack[(stkpnt << 1) - 2] = j + 1;
		stack[(stkpnt << 1) - 1] = endd;
		++stkpnt;
		stack[(stkpnt << 1) - 2] = start;
		stack[(stkpnt << 1) - 1] = j;
	    }
	}
    }
    if (stkpnt > 0) {
	goto L10;
    }
    return 0;

 

}  

  int dlassq_(n, x, incx, scale, sumsq)
integer *n;
doublereal *x;
integer *incx;
doublereal *scale, *sumsq;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    static doublereal absxi;
    static integer ix;
     
    --x;

     
    if (*n > 0) {
	i__1 = (*n - 1) * *incx + 1;
	i__2 = *incx;
	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
	    if (x[ix] != 0.) {
		absxi = (d__1 = x[ix], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (*scale < absxi) {
 
		    d__1 = *scale / absxi;
		    *sumsq = *sumsq * (d__1 * d__1) + 1;
		    *scale = absxi;
		} else {
 
		    d__1 = absxi / *scale;
		    *sumsq += d__1 * d__1;
		}
	    }
 
	}
    }
    return 0;

 

}  

  int dlatrs_(uplo, trans, diag, normin, n, a, lda, x, scale, 
	cnorm, info, uplo_len, trans_len, diag_len, normin_len)
char *uplo, *trans, *diag, *normin;
integer *n;
doublereal *a;
integer *lda;
doublereal *x, *scale, *cnorm;
integer *info;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
ftnlen normin_len;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1, d__2, d__3;

     
    static integer jinc;
    extern doublereal ddot_();
    static doublereal xbnd;
    static integer imax;
    static doublereal tmax, tjjs, xmax, grow, sumj;
    static integer i__, j;
    extern   int dscal_();
    extern logical lsame_();
    static doublereal tscal, uscal;
    extern doublereal dasum_();
    static integer jlast;
    extern   int daxpy_();
    static logical upper;
    extern   int dtrsv_();
    extern doublereal dlamch_();
    static doublereal xj;
    extern integer idamax_();
    extern   int xerbla_();
    static doublereal bignum;
    static logical notran;
    static integer jfirst;
    static doublereal smlnum;
    static logical nounit;
    static doublereal rec, tjj;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --x;
    --cnorm;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    notran = lsame_(trans, "N", 1L, 1L);
    nounit = lsame_(diag, "N", 1L, 1L);

 

    if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, 
	    "C", 1L, 1L)) {
	*info = -2;
    } else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) {
	*info = -3;
    } else if (! lsame_(normin, "Y", 1L, 1L) && ! lsame_(normin, "N", 1L, 1L))
	     {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	*info = -7;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DLATRS", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

 

    smlnum = dlamch_("Safe minimum", 12L) / dlamch_("Precision", 9L);
    bignum = 1. / smlnum;
    *scale = 1.;

    if (lsame_(normin, "N", 1L, 1L)) {

 


	if (upper) {

 

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j - 1;
		cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
 
	    }
	} else {

 

	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n - j;
		cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
 
	    }
	    cnorm[*n] = 0.;
	}
    }

 

 

    imax = idamax_(n, &cnorm[1], &c__1);
    tmax = cnorm[imax];
    if (tmax <= bignum) {
	tscal = 1.;
    } else {
	tscal = 1. / (smlnum * tmax);
	dscal_(n, &tscal, &cnorm[1], &c__1);
    }

 
 

    j = idamax_(n, &x[1], &c__1);
    xmax = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    xbnd = xmax;
    if (notran) {

 

	if (upper) {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	} else {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	}

	if (tscal != 1.) {
	    grow = 0.;
	    goto L50;
	}

	if (nounit) {

 

 
 

	    grow = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ;
	    xbnd = grow;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

 


		if (grow <= smlnum) {
		    goto L50;
		}

 

		tjj = (d__1 = a[j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
		d__1 = xbnd, d__2 = (( 1. ) <= ( tjj ) ? ( 1. ) : ( tjj ))  * grow;
		xbnd = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
		if (tjj + cnorm[j] >= smlnum) {

 


		    grow *= tjj / (tjj + cnorm[j]);
		} else {

 

		    grow = 0.;
		}
 
	    }
	    grow = xbnd;
	} else {

 

 


 
	    d__1 = 1., d__2 = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ;
	    grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

 


		if (grow <= smlnum) {
		    goto L50;
		}

 

		grow *= 1. / (cnorm[j] + 1.);
 
	    }
	}
L50:

	;
    } else {

 

	if (upper) {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	} else {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	}

	if (tscal != 1.) {
	    grow = 0.;
	    goto L80;
	}

	if (nounit) {

 

 
 

	    grow = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ;
	    xbnd = grow;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

 


		if (grow <= smlnum) {
		    goto L80;
		}

 


		xj = cnorm[j] + 1.;
 
		d__1 = grow, d__2 = xbnd / xj;
		grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;

 


		tjj = (d__1 = a[j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (xj > tjj) {
		    xbnd *= tjj / xj;
		}
 
	    }
	    grow = (( grow ) <= ( xbnd ) ? ( grow ) : ( xbnd )) ;
	} else {

 

 


 
	    d__1 = 1., d__2 = 1. / (( xbnd ) >= ( smlnum ) ? ( xbnd ) : ( smlnum )) ;
	    grow = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

 


		if (grow <= smlnum) {
		    goto L80;
		}

 

		xj = cnorm[j] + 1.;
		grow /= xj;
 
	    }
	}
L80:
	;
    }

    if (grow * tscal > smlnum) {

 

 

	dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, 1L, 1L, 
		1L);
    } else {

 

	if (xmax > bignum) {

 

 

	    *scale = bignum / xmax;
	    dscal_(n, scale, &x[1], &c__1);
	    xmax = bignum;
	}

	if (notran) {

 

	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

 


		xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (nounit) {
		    tjjs = a[j + j * a_dim1] * tscal;
		} else {
		    tjjs = tscal;
		    if (tscal == 1.) {
			goto L100;
		    }
		}
		tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ;
		if (tjj > smlnum) {

 

		    if (tjj < 1.) {
			if (xj > tjj * bignum) {

 

			    rec = 1. / xj;
			    dscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
		    }
		    x[j] /= tjjs;
		    xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		} else if (tjj > 0.) {

 

		    if (xj > tjj * bignum) {

 

 


			rec = tjj * bignum / xj;
			if (cnorm[j] > 1.) {

 

 


			    rec /= cnorm[j];
			}
			dscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		    x[j] /= tjjs;
		    xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		} else {

 

 


		    i__3 = *n;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			x[i__] = 0.;
 
		    }
		    x[j] = 1.;
		    xj = 1.;
		    *scale = 0.;
		    xmax = 0.;
		}
L100:

 

 

		if (xj > 1.) {
		    rec = 1. / xj;
		    if (cnorm[j] > (bignum - xmax) * rec) {

 

			rec *= .5;
			dscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
		    }
		} else if (xj * cnorm[j] > bignum - xmax) {

 

		    dscal_(n, &c_b806, &x[1], &c__1);
		    *scale *= .5;
		}

		if (upper) {
		    if (j > 1) {

 
 


			i__3 = j - 1;
			d__1 = -x[j] * tscal;
			daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1],
				 &c__1);
			i__3 = j - 1;
			i__ = idamax_(&i__3, &x[1], &c__1);
			xmax = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    }
		} else {
		    if (j < *n) {

 
 


			i__3 = *n - j;
			d__1 = -x[j] * tscal;
			daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, &
				x[j + 1], &c__1);
			i__3 = *n - j;
			i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
			xmax = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    }
		}
 
	    }

	} else {

 

	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

 
 

		xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		uscal = tscal;
		rec = 1. / (( xmax ) >= ( 1. ) ? ( xmax ) : ( 1. )) ;
		if (cnorm[j] > (bignum - xj) * rec) {

 


		    rec *= .5;
		    if (nounit) {
			tjjs = a[j + j * a_dim1] * tscal;
		    } else {
			tjjs = tscal;
		    }
		    tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ;
		    if (tjj > 1.) {

 


 
			d__1 = 1., d__2 = rec * tjj;
			rec = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
			uscal /= tjjs;
		    }
		    if (rec < 1.) {
			dscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		sumj = 0.;
		if (uscal == 1.) {

 

 


		    if (upper) {
			i__3 = j - 1;
			sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], 
				&c__1);
		    } else if (j < *n) {
			i__3 = *n - j;
			sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[
				j + 1], &c__1);
		    }
		} else {

 


		    if (upper) {
			i__3 = j - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    sumj += a[i__ + j * a_dim1] * uscal * x[i__];
 
			}
		    } else if (j < *n) {
			i__3 = *n;
			for (i__ = j + 1; i__ <= i__3; ++i__) {
			    sumj += a[i__ + j * a_dim1] * uscal * x[i__];
 
			}
		    }
		}

		if (uscal == tscal) {

 

 


		    x[j] -= sumj;
		    xj = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		    if (nounit) {
			tjjs = a[j + j * a_dim1] * tscal;
		    } else {
			tjjs = tscal;
			if (tscal == 1.) {
			    goto L150;
			}
		    }

 


		    tjj = (( tjjs ) >= 0 ? ( tjjs ) : -( tjjs )) ;
		    if (tjj > smlnum) {

 

			if (tjj < 1.) {
			    if (xj > tjj * bignum) {

 


				rec = 1. / xj;
				dscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			x[j] /= tjjs;
		    } else if (tjj > 0.) {

 

			if (xj > tjj * bignum) {

 


			    rec = tjj * bignum / xj;
			    dscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			x[j] /= tjjs;
		    } else {

 

 


			i__3 = *n;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    x[i__] = 0.;
 
			}
			x[j] = 1.;
			*scale = 0.;
			xmax = 0.;
		    }
L150:
		    ;
		} else {

 

 


		    x[j] = x[j] / tjjs - sumj;
		}
 
		d__2 = xmax, d__3 = (d__1 = x[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		xmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	    }
	}
	*scale /= tscal;
    }

 

    if (tscal != 1.) {
	d__1 = 1. / tscal;
	dscal_(n, &d__1, &cnorm[1], &c__1);
    }

    return 0;

 

}  

  int dopgtr_(uplo, n, ap, tau, q, ldq, work, info, uplo_len)
char *uplo;
integer *n;
doublereal *ap, *tau, *q;
integer *ldq;
doublereal *work;
integer *info;
ftnlen uplo_len;
{
     
    integer q_dim1, q_offset, i__1, i__2, i__3;

     
    static integer i__, j;
    extern logical lsame_();
    static integer iinfo;
    static logical upper;
    extern   int dorg2l_(), dorg2r_();
    static integer ij;
    extern   int xerbla_();
    --ap;
    --tau;
    q_dim1 = *ldq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    --work;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*ldq < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	*info = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DOPGTR", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    if (upper) {

 

 

 

 

	ij = 2;
	i__1 = *n - 1;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j - 1;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		q[i__ + j * q_dim1] = ap[ij];
		++ij;
 
	    }
	    ij += 2;
	    q[*n + j * q_dim1] = 0.;
 
	}
	i__1 = *n - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    q[i__ + *n * q_dim1] = 0.;
 
	}
	q[*n + *n * q_dim1] = 1.;

 

	i__1 = *n - 1;
	i__2 = *n - 1;
	i__3 = *n - 1;
	dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], &
		iinfo);

    } else {

 

 

 

 

	q[q_dim1 + 1] = 1.;
	i__1 = *n;
	for (i__ = 2; i__ <= i__1; ++i__) {
	    q[i__ + q_dim1] = 0.;
 
	}
	ij = 3;
	i__1 = *n;
	for (j = 2; j <= i__1; ++j) {
	    q[j * q_dim1 + 1] = 0.;
	    i__2 = *n;
	    for (i__ = j + 1; i__ <= i__2; ++i__) {
		q[i__ + j * q_dim1] = ap[ij];
		++ij;
 
	    }
	    ij += 2;
 
	}
	if (*n > 1) {

 

	    i__1 = *n - 1;
	    i__2 = *n - 1;
	    i__3 = *n - 1;
	    dorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], 
		    &work[1], &iinfo);
	}
    }
    return 0;

 

}  

  int dorg2l_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
     
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1;

     
    static integer i__, j, l;
    extern   int dscal_(), dlarf_();
    static integer ii;
    extern   int xerbla_();
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;

     
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0 || *n > *m) {
	*info = -2;
    } else if (*k < 0 || *k > *n) {
	*info = -3;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORG2L", &i__1, 6L);
	return 0;
    }

 

    if (*n <= 0) {
	return 0;
    }

 

    i__1 = *n - *k;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
	    a[l + j * a_dim1] = 0.;
 
	}
	a[*m - *n + j + j * a_dim1] = 1.;
 
    }

    i__1 = *k;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ii = *n - *k + i__;

 

	a[*m - *n + ii + ii * a_dim1] = 1.;
	i__2 = *m - *n + ii;
	i__3 = ii - 1;
	dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
		a[a_offset], lda, &work[1], 4L);
	i__2 = *m - *n + ii - 1;
	d__1 = -tau[i__];
	dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1);
	a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__];

 

	i__2 = *m;
	for (l = *m - *n + ii + 1; l <= i__2; ++l) {
	    a[l + ii * a_dim1] = 0.;
 
	}
 
    }
    return 0;

 

}  

  int dorg2r_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1;

     
    static integer i__, j, l;
    extern   int dscal_(), dlarf_(), xerbla_();
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    --work;

     
    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0 || *n > *m) {
	*info = -2;
    } else if (*k < 0 || *k > *n) {
	*info = -3;
    } else if (*lda < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORG2R", &i__1, 6L);
	return 0;
    }

 

    if (*n <= 0) {
	return 0;
    }

 

    i__1 = *n;
    for (j = *k + 1; j <= i__1; ++j) {
	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
	    a[l + j * a_dim1] = 0.;
 
	}
	a[j + j * a_dim1] = 1.;
 
    }

    for (i__ = *k; i__ >= 1; --i__) {

 

	if (i__ < *n) {
	    a[i__ + i__ * a_dim1] = 1.;
	    i__1 = *m - i__ + 1;
	    i__2 = *n - i__;
	    dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
		    i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
	}
	if (i__ < *m) {
	    i__1 = *m - i__;
	    d__1 = -tau[i__];
	    dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
	}
	a[i__ + i__ * a_dim1] = 1. - tau[i__];

 

	i__1 = i__ - 1;
	for (l = 1; l <= i__1; ++l) {
	    a[l + i__ * a_dim1] = 0.;
 
	}
 
    }
    return 0;

 

}  

  int dorm2r_(side, trans, m, n, k, a, lda, tau, c__, ldc, 
	work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *info;
ftnlen side_len;
ftnlen trans_len;
{
     
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;

     
    static logical left;
    static integer i__;
    extern   int dlarf_();
    extern logical lsame_();
    static integer i1, i2, i3, ic, jc, mi, ni, nq;
    extern   int xerbla_();
    static logical notran;
    static doublereal aii;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --work;

     
    *info = 0;
    left = lsame_(side, "L", 1L, 1L);
    notran = lsame_(trans, "N", 1L, 1L);

 

    if (left) {
	nq = *m;
    } else {
	nq = *n;
    }
    if (! left && ! lsame_(side, "R", 1L, 1L)) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
	*info = -2;
    } else if (*m < 0) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*k < 0 || *k > nq) {
	*info = -5;
    } else if (*lda < (( 1 ) >= ( nq ) ? ( 1 ) : ( nq )) ) {
	*info = -7;
    } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -10;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORM2R", &i__1, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *k == 0) {
	return 0;
    }

    if (left && ! notran || ! left && notran) {
	i1 = 1;
	i2 = *k;
	i3 = 1;
    } else {
	i1 = *k;
	i2 = 1;
	i3 = -1;
    }

    if (left) {
	ni = *n;
	jc = 1;
    } else {
	mi = *m;
	ic = 1;
    }

    i__1 = i2;
    i__2 = i3;
    for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
	if (left) {

 

	    mi = *m - i__ + 1;
	    ic = i__;
	} else {

 

	    ni = *n - i__ + 1;
	    jc = i__;
	}

 

	aii = a[i__ + i__ * a_dim1];
	a[i__ + i__ * a_dim1] = 1.;
	dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
		ic + jc * c_dim1], ldc, &work[1], 1L);
	a[i__ + i__ * a_dim1] = aii;
 
    }
    return 0;

 

}  

  int dorml2_(side, trans, m, n, k, a, lda, tau, c__, ldc, 
	work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *info;
ftnlen side_len;
ftnlen trans_len;
{
     
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;

     
    static logical left;
    static integer i__;
    extern   int dlarf_();
    extern logical lsame_();
    static integer i1, i2, i3, ic, jc, mi, ni, nq;
    extern   int xerbla_();
    static logical notran;
    static doublereal aii;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --work;

     
    *info = 0;
    left = lsame_(side, "L", 1L, 1L);
    notran = lsame_(trans, "N", 1L, 1L);

 

    if (left) {
	nq = *m;
    } else {
	nq = *n;
    }
    if (! left && ! lsame_(side, "R", 1L, 1L)) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
	*info = -2;
    } else if (*m < 0) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*k < 0 || *k > nq) {
	*info = -5;
    } else if (*lda < (( 1 ) >= ( *k ) ? ( 1 ) : ( *k )) ) {
	*info = -7;
    } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -10;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORML2", &i__1, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *k == 0) {
	return 0;
    }

    if (left && notran || ! left && ! notran) {
	i1 = 1;
	i2 = *k;
	i3 = 1;
    } else {
	i1 = *k;
	i2 = 1;
	i3 = -1;
    }

    if (left) {
	ni = *n;
	jc = 1;
    } else {
	mi = *m;
	ic = 1;
    }

    i__1 = i2;
    i__2 = i3;
    for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
	if (left) {

 

	    mi = *m - i__ + 1;
	    ic = i__;
	} else {

 

	    ni = *n - i__ + 1;
	    jc = i__;
	}

 

	aii = a[i__ + i__ * a_dim1];
	a[i__ + i__ * a_dim1] = 1.;
	dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
		ic + jc * c_dim1], ldc, &work[1], 1L);
	a[i__ + i__ * a_dim1] = aii;
 
    }
    return 0;

 

}  

  int dormlq_(side, trans, m, n, k, a, lda, tau, c__, ldc, 
	work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
     
    address a__1[2];
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, 
	    i__5;
    char ch__1[2];

     
      int s_cat();

     
    static logical left;
    static integer i__;
    static doublereal t[4160]	 ;
    extern logical lsame_();
    static integer nbmin, iinfo, i1, i2, i3;
    extern   int dorml2_();
    static integer ib, ic, jc, nb, mi, ni;
    extern   int dlarfb_();
    static integer nq, nw;
    extern   int dlarft_(), xerbla_();
    extern integer ilaenv_();
    static logical notran;
    static integer ldwork;
    static char transt[1];
    static integer iws;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --work;

     
    *info = 0;
    left = lsame_(side, "L", 1L, 1L);
    notran = lsame_(trans, "N", 1L, 1L);

 

    if (left) {
	nq = *m;
	nw = *n;
    } else {
	nq = *n;
	nw = *m;
    }
    if (! left && ! lsame_(side, "R", 1L, 1L)) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
	*info = -2;
    } else if (*m < 0) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*k < 0 || *k > nq) {
	*info = -5;
    } else if (*lda < (( 1 ) >= ( *k ) ? ( 1 ) : ( *k )) ) {
	*info = -7;
    } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -10;
    } else if (*lwork < (( 1 ) >= ( nw ) ? ( 1 ) : ( nw )) ) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORMLQ", &i__1, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *k == 0) {
	work[1] = 1.;
	return 0;
    }

 
 

 
 
    i__3[0] = 1, a__1[0] = side;
    i__3[1] = 1, a__1[1] = trans;
    s_cat(ch__1, a__1, i__3, &c__2, 2L);
    i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1, 6L, 2L);
    nb = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    nbmin = 2;
    ldwork = nw;
    if (nb > 1 && nb < *k) {
	iws = nw * nb;
	if (*lwork < iws) {
	    nb = *lwork / ldwork;
 
 
	    i__3[0] = 1, a__1[0] = side;
	    i__3[1] = 1, a__1[1] = trans;
	    s_cat(ch__1, a__1, i__3, &c__2, 2L);
	    i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1, 
		    6L, 2L);
	    nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	}
    } else {
	iws = nw;
    }

    if (nb < nbmin || nb >= *k) {

 

	dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
		c_offset], ldc, &work[1], &iinfo, 1L, 1L);
    } else {

 

	if (left && notran || ! left && ! notran) {
	    i1 = 1;
	    i2 = *k;
	    i3 = nb;
	} else {
	    i1 = (*k - 1) / nb * nb + 1;
	    i2 = 1;
	    i3 = -nb;
	}

	if (left) {
	    ni = *n;
	    jc = 1;
	} else {
	    mi = *m;
	    ic = 1;
	}

	if (notran) {
	    *(unsigned char *)transt = 'T';
	} else {
	    *(unsigned char *)transt = 'N';
	}

	i__1 = i2;
	i__2 = i3;
	for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
 
	    i__4 = nb, i__5 = *k - i__ + 1;
	    ib = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;

 
 

	    i__4 = nq - i__ + 1;
	    dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], 
		    lda, &tau[i__], t, &c__65, 7L, 7L);
	    if (left) {

 

		mi = *m - i__ + 1;
		ic = i__;
	    } else {

 

		ni = *n - i__ + 1;
		jc = i__;
	    }

 

	    dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ 
		    + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], 
		    ldc, &work[1], &ldwork, 1L, 1L, 7L, 7L);
 
	}
    }
    work[1] = (doublereal) iws;
    return 0;

 

}  

  int dormqr_(side, trans, m, n, k, a, lda, tau, c__, ldc, 
	work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
     
    address a__1[2];
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, 
	    i__5;
    char ch__1[2];

     
      int s_cat();

     
    static logical left;
    static integer i__;
    static doublereal t[4160]	 ;
    extern logical lsame_();
    static integer nbmin, iinfo, i1, i2, i3;
    extern   int dorm2r_();
    static integer ib, ic, jc, nb, mi, ni;
    extern   int dlarfb_();
    static integer nq, nw;
    extern   int dlarft_(), xerbla_();
    extern integer ilaenv_();
    static logical notran;
    static integer ldwork, iws;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --tau;
    c_dim1 = *ldc;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --work;

     
    *info = 0;
    left = lsame_(side, "L", 1L, 1L);
    notran = lsame_(trans, "N", 1L, 1L);

 

    if (left) {
	nq = *m;
	nw = *n;
    } else {
	nq = *n;
	nw = *m;
    }
    if (! left && ! lsame_(side, "R", 1L, 1L)) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
	*info = -2;
    } else if (*m < 0) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*k < 0 || *k > nq) {
	*info = -5;
    } else if (*lda < (( 1 ) >= ( nq ) ? ( 1 ) : ( nq )) ) {
	*info = -7;
    } else if (*ldc < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	*info = -10;
    } else if (*lwork < (( 1 ) >= ( nw ) ? ( 1 ) : ( nw )) ) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DORMQR", &i__1, 6L);
	return 0;
    }

 

    if (*m == 0 || *n == 0 || *k == 0) {
	work[1] = 1.;
	return 0;
    }

 
 

 
 
    i__3[0] = 1, a__1[0] = side;
    i__3[1] = 1, a__1[1] = trans;
    s_cat(ch__1, a__1, i__3, &c__2, 2L);
    i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, 6L, 2L);
    nb = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    nbmin = 2;
    ldwork = nw;
    if (nb > 1 && nb < *k) {
	iws = nw * nb;
	if (*lwork < iws) {
	    nb = *lwork / ldwork;
 
 
	    i__3[0] = 1, a__1[0] = side;
	    i__3[1] = 1, a__1[1] = trans;
	    s_cat(ch__1, a__1, i__3, &c__2, 2L);
	    i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, 
		    6L, 2L);
	    nbmin = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	}
    } else {
	iws = nw;
    }

    if (nb < nbmin || nb >= *k) {

 

	dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
		c_offset], ldc, &work[1], &iinfo, 1L, 1L);
    } else {

 

	if (left && ! notran || ! left && notran) {
	    i1 = 1;
	    i2 = *k;
	    i3 = nb;
	} else {
	    i1 = (*k - 1) / nb * nb + 1;
	    i2 = 1;
	    i3 = -nb;
	}

	if (left) {
	    ni = *n;
	    jc = 1;
	} else {
	    mi = *m;
	    ic = 1;
	}

	i__1 = i2;
	i__2 = i3;
	for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
 
	    i__4 = nb, i__5 = *k - i__ + 1;
	    ib = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;

 
 

	    i__4 = nq - i__ + 1;
	    dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * 
		    a_dim1], lda, &tau[i__], t, &c__65, 7L, 10L);
	    if (left) {

 

		mi = *m - i__ + 1;
		ic = i__;
	    } else {

 

		ni = *n - i__ + 1;
		jc = i__;
	    }

 

	    dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
		    i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * 
		    c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 10L);
 
	}
    }
    work[1] = (doublereal) iws;
    return 0;

 

}  

  int dpptrf_(uplo, n, ap, info, uplo_len)
char *uplo;
integer *n;
doublereal *ap;
integer *info;
ftnlen uplo_len;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    double sqrt();

     
    extern doublereal ddot_();
    extern   int dspr_();
    static integer j;
    extern   int dscal_();
    extern logical lsame_();
    static logical upper;
    extern   int dtpsv_();
    static integer jc, jj;
    extern   int xerbla_();
    static doublereal ajj;
     
    --ap;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPPTRF", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    if (upper) {

 

	jj = 0;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    jc = jj + 1;
	    jj += j;

 

	    if (j > 1) {
		i__2 = j - 1;
		dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
			jc], &c__1, 5L, 9L, 8L);
	    }

 


	    i__2 = j - 1;
	    ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ap[jj] = sqrt(ajj);
 
	}
    } else {

 

	jj = 1;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {

 


	    ajj = ap[jj];
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    ap[jj] = ajj;

 

 

	    if (j < *n) {
		i__2 = *n - j;
		d__1 = 1. / ajj;
		dscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
		i__2 = *n - j;
		dspr_("Lower", &i__2, &c_b418, &ap[jj + 1], &c__1, &ap[jj + *
			n - j + 1], 5L);
		jj = jj + *n - j + 1;
	    }
 
	}
    }
    goto L40;

L30:
    *info = j;

L40:
    return 0;

 

}  

  int drscl_(n, sa, sx, incx)
integer *n;
doublereal *sa, *sx;
integer *incx;
{
    static doublereal cden;
    static logical done;
    static doublereal cnum, cden1, cnum1;
    extern   int dscal_(), dlabad_();
    extern doublereal dlamch_();
    static doublereal bignum, smlnum, mul;
    --sx;

     
    if (*n <= 0) {
	return 0;
    }

 

    smlnum = dlamch_("S", 1L);
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

 

    cden = *sa;
    cnum = 1.;

L10:
    cden1 = cden * smlnum;
    cnum1 = cnum / bignum;
    if ((( cden1 ) >= 0 ? ( cden1 ) : -( cden1 ))  > (( cnum ) >= 0 ? ( cnum ) : -( cnum ))  && cnum != 0.) {

 


	mul = smlnum;
	done = (0) ;
	cden = cden1;
    } else if ((( cnum1 ) >= 0 ? ( cnum1 ) : -( cnum1 ))  > (( cden ) >= 0 ? ( cden ) : -( cden )) ) {

 


	mul = bignum;
	done = (0) ;
	cnum = cnum1;
    } else {

 

	mul = cnum / cden;
	done = (1) ;
    }

 

    dscal_(n, &mul, &sx[1], incx);

    if (! done) {
	goto L10;
    }

    return 0;

 

}  

  int dspev_(jobz, uplo, n, ap, w, z__, ldz, work, info, 
	jobz_len, uplo_len)
char *jobz, *uplo;
integer *n;
doublereal *ap, *w, *z__;
integer *ldz;
doublereal *work;
integer *info;
ftnlen jobz_len;
ftnlen uplo_len;
{
     
    integer z_dim1, z_offset, i__1;
    doublereal d__1;

     
    double sqrt();

     
    static integer inde;
    static doublereal anrm;
    static integer imax;
    static doublereal rmin, rmax;
    extern   int dscal_();
    static doublereal sigma;
    extern logical lsame_();
    static integer iinfo;
    static logical wantz;
    extern doublereal dlamch_();
    static integer iscale;
    static doublereal safmin;
    extern   int xerbla_();
    static doublereal bignum;
    extern doublereal dlansp_();
    static integer indtau;
    extern   int dsterf_();
    static integer indwrk;
    extern   int dopgtr_(), dsptrd_(), dsteqr_();
    static doublereal smlnum, eps;
    --ap;
    --w;
    z_dim1 = *ldz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --work;

     
    wantz = lsame_(jobz, "V", 1L, 1L);

    *info = 0;
    if (! (wantz || lsame_(jobz, "N", 1L, 1L))) {
	*info = -1;
    } else if (! (lsame_(uplo, "U", 1L, 1L) || lsame_(uplo, "L", 1L, 1L))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -7;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPEV ", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	w[1] = ap[1];
	if (wantz) {
	    z__[z_dim1 + 1] = 1.;
	}
	return 0;
    }

 

    safmin = dlamch_("Safe minimum", 12L);
    eps = dlamch_("Precision", 9L);
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

 

    anrm = dlansp_("M", uplo, n, &ap[1], &work[1], 1L, 1L);
    iscale = 0;
    if (anrm > 0. && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	i__1 = *n * (*n + 1) / 2;
	dscal_(&i__1, &sigma, &ap[1], &c__1);
    }

 


    inde = 1;
    indtau = inde + *n;
    dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo, 1L);

 
 

    if (! wantz) {
	dsterf_(n, &w[1], &work[inde], info);
    } else {
	indwrk = indtau + *n;
	dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
		indwrk], &iinfo, 1L);
	dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
		indtau], info, 1L);
    }

 

    if (iscale == 1) {
	if (*info == 0) {
	    imax = *n;
	} else {
	    imax = *info - 1;
	}
	d__1 = 1. / sigma;
	dscal_(&imax, &d__1, &w[1], &c__1);
    }

    return 0;

 

}  

  int dspgst_(itype, uplo, n, ap, bp, info, uplo_len)
integer *itype;
char *uplo;
integer *n;
doublereal *ap, *bp;
integer *info;
ftnlen uplo_len;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    extern doublereal ddot_();
    extern   int dspr2_();
    static integer j, k;
    extern   int dscal_();
    extern logical lsame_();
    extern   int daxpy_(), dspmv_();
    static logical upper;
    static integer j1, k1;
    extern   int dtpmv_(), dtpsv_();
    static integer jj, kk;
    static doublereal ct;
    extern   int xerbla_();
    static doublereal ajj;
    static integer j1j1;
    static doublereal akk;
    static integer k1k1;
    static doublereal bjj, bkk;
    --bp;
    --ap;
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    if (*itype < 1 || *itype > 3) {
	*info = -1;
    } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPGST", &i__1, 6L);
	return 0;
    }

    if (*itype == 1) {
	if (upper) {

 

 

	    jj = 0;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		j1 = jj + 1;
		jj += j;

 


		bjj = bp[jj];
		dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
			c__1, 1L, 9L, 7L);
		i__2 = j - 1;
		dspmv_(uplo, &i__2, &c_b418, &ap[1], &bp[j1], &c__1, &c_b89, &
			ap[j1], &c__1, 1L);
		i__2 = j - 1;
		d__1 = 1. / bjj;
		dscal_(&i__2, &d__1, &ap[j1], &c__1);
		i__2 = j - 1;
		ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], &
			c__1)) / bjj;
 
	    }
	} else {

 

 


	    kk = 1;
	    i__1 = *n;
	    for (k = 1; k <= i__1; ++k) {
		k1k1 = kk + *n - k + 1;

 

		akk = ap[kk];
		bkk = bp[kk];
 
		d__1 = bkk;
		akk /= d__1 * d__1;
		ap[kk] = akk;
		if (k < *n) {
		    i__2 = *n - k;
		    d__1 = 1. / bkk;
		    dscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
		    ct = akk * -.5;
		    i__2 = *n - k;
		    daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
			    ;
		    i__2 = *n - k;
		    dspr2_(uplo, &i__2, &c_b418, &ap[kk + 1], &c__1, &bp[kk + 
			    1], &c__1, &ap[k1k1], 1L);
		    i__2 = *n - k;
		    daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
			    ;
		    i__2 = *n - k;
		    dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
			     &ap[kk + 1], &c__1, 1L, 12L, 8L);
		}
		kk = k1k1;
 
	    }
	}
    } else {
	if (upper) {

 

 

	    kk = 0;
	    i__1 = *n;
	    for (k = 1; k <= i__1; ++k) {
		k1 = kk + 1;
		kk += k;

 

		akk = ap[kk];
		bkk = bp[kk];
		i__2 = k - 1;
		dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
			k1], &c__1, 1L, 12L, 8L);
		ct = akk * .5;
		i__2 = k - 1;
		daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
		i__2 = k - 1;
		dspr2_(uplo, &i__2, &c_b89, &ap[k1], &c__1, &bp[k1], &c__1, &
			ap[1], 1L);
		i__2 = k - 1;
		daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
		i__2 = k - 1;
		dscal_(&i__2, &bkk, &ap[k1], &c__1);
 
		d__1 = bkk;
		ap[kk] = akk * (d__1 * d__1);
 
	    }
	} else {

 

 


	    jj = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		j1j1 = jj + *n - j + 1;

 


		ajj = ap[jj];
		bjj = bp[jj];
		i__2 = *n - j;
		ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj 
			+ 1], &c__1);
		i__2 = *n - j;
		dscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
		i__2 = *n - j;
		dspmv_(uplo, &i__2, &c_b89, &ap[j1j1], &bp[jj + 1], &c__1, &
			c_b89, &ap[jj + 1], &c__1, 1L);
		i__2 = *n - j + 1;
		dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
			 &c__1, 1L, 9L, 8L);
		jj = j1j1;
 
	    }
	}
    }
    return 0;

 

}  

  int dspgv_(itype, jobz, uplo, n, ap, bp, w, z__, ldz, work, 
	info, jobz_len, uplo_len)
integer *itype;
char *jobz, *uplo;
integer *n;
doublereal *ap, *bp, *w, *z__;
integer *ldz;
doublereal *work;
integer *info;
ftnlen jobz_len;
ftnlen uplo_len;
{
     
    integer z_dim1, z_offset, i__1;

     
    static integer neig, j;
    extern logical lsame_();
    extern   int dspev_();
    static char trans[1];
    static logical upper;
    extern   int dtpmv_(), dtpsv_();
    static logical wantz;
    extern   int xerbla_(), dpptrf_(), dspgst_();
     
    --ap;
    --bp;
    --w;
    z_dim1 = *ldz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --work;

     
    wantz = lsame_(jobz, "V", 1L, 1L);
    upper = lsame_(uplo, "U", 1L, 1L);

    *info = 0;
    if (*itype < 0 || *itype > 3) {
	*info = -1;
    } else if (! (wantz || lsame_(jobz, "N", 1L, 1L))) {
	*info = -2;
    } else if (! (upper || lsame_(uplo, "L", 1L, 1L))) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -9;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPGV ", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

 

    dpptrf_(uplo, n, &bp[1], info, 1L);
    if (*info != 0) {
	*info = *n + *info;
	return 0;
    }

 

    dspgst_(itype, uplo, n, &ap[1], &bp[1], info, 1L);
    dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info, 
	    1L, 1L);

    if (wantz) {

 

	neig = *n;
	if (*info > 0) {
	    neig = *info - 1;
	}
	if (*itype == 1 || *itype == 2) {

 
 


	    if (upper) {
		*(unsigned char *)trans = 'N';
	    } else {
		*(unsigned char *)trans = 'T';
	    }

	    i__1 = neig;
	    for (j = 1; j <= i__1; ++j) {
		dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
			1], &c__1, 1L, 1L, 8L);
 
	    }

	} else if (*itype == 3) {

 
 

	    if (upper) {
		*(unsigned char *)trans = 'T';
	    } else {
		*(unsigned char *)trans = 'N';
	    }

	    i__1 = neig;
	    for (j = 1; j <= i__1; ++j) {
		dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
			1], &c__1, 1L, 1L, 8L);
 
	    }
	}
    }
    return 0;

 

}  

  int dspmv_(uplo, n, alpha, ap, x, incx, beta, y, incy, 
	uplo_len)
char *uplo;
integer *n;
doublereal *alpha, *ap, *x;
integer *incx;
doublereal *beta, *y;
integer *incy;
ftnlen uplo_len;
{
     
    integer i__1, i__2;

     
    static integer info;
    static doublereal temp1, temp2;
    static integer i__, j, k;
    extern logical lsame_();
    static integer kk, ix, iy, jx, jy, kx, ky;
    extern   int xerbla_();
     
    --y;
    --x;
    --ap;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (*n < 0) {
	info = 2;
    } else if (*incx == 0) {
	info = 6;
    } else if (*incy == 0) {
	info = 9;
    }
    if (info != 0) {
	xerbla_("DSPMV ", &info, 6L);
	return 0;
    }

 

    if (*n == 0 || *alpha == 0. && *beta == 1.) {
	return 0;
    }

 

    if (*incx > 0) {
	kx = 1;
    } else {
	kx = 1 - (*n - 1) * *incx;
    }
    if (*incy > 0) {
	ky = 1;
    } else {
	ky = 1 - (*n - 1) * *incy;
    }

 

 

 

    if (*beta != 1.) {
	if (*incy == 1) {
	    if (*beta == 0.) {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[i__] = 0.;
 
		}
	    } else {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[i__] = *beta * y[i__];
 
		}
	    }
	} else {
	    iy = ky;
	    if (*beta == 0.) {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[iy] = 0.;
		    iy += *incy;
 
		}
	    } else {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    y[iy] = *beta * y[iy];
		    iy += *incy;
 
		}
	    }
	}
    }
    if (*alpha == 0.) {
	return 0;
    }
    kk = 1;
    if (lsame_(uplo, "U", 1L, 1L)) {

 

	if (*incx == 1 && *incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp1 = *alpha * x[j];
		temp2 = 0.;
		k = kk;
		i__2 = j - 1;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    y[i__] += temp1 * ap[k];
		    temp2 += ap[k] * x[i__];
		    ++k;
 
		}
		y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
		kk += j;
 
	    }
	} else {
	    jx = kx;
	    jy = ky;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp1 = *alpha * x[jx];
		temp2 = 0.;
		ix = kx;
		iy = ky;
		i__2 = kk + j - 2;
		for (k = kk; k <= i__2; ++k) {
		    y[iy] += temp1 * ap[k];
		    temp2 += ap[k] * x[ix];
		    ix += *incx;
		    iy += *incy;
 
		}
		y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
		jx += *incx;
		jy += *incy;
		kk += j;
 
	    }
	}
    } else {

 

	if (*incx == 1 && *incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp1 = *alpha * x[j];
		temp2 = 0.;
		y[j] += temp1 * ap[kk];
		k = kk + 1;
		i__2 = *n;
		for (i__ = j + 1; i__ <= i__2; ++i__) {
		    y[i__] += temp1 * ap[k];
		    temp2 += ap[k] * x[i__];
		    ++k;
 
		}
		y[j] += *alpha * temp2;
		kk += *n - j + 1;
 
	    }
	} else {
	    jx = kx;
	    jy = ky;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		temp1 = *alpha * x[jx];
		temp2 = 0.;
		y[jy] += temp1 * ap[kk];
		ix = jx;
		iy = jy;
		i__2 = kk + *n - j;
		for (k = kk + 1; k <= i__2; ++k) {
		    ix += *incx;
		    iy += *incy;
		    y[iy] += temp1 * ap[k];
		    temp2 += ap[k] * x[ix];
 
		}
		y[jy] += *alpha * temp2;
		jx += *incx;
		jy += *incy;
		kk += *n - j + 1;
 
	    }
	}
    }

    return 0;

 

}  

  int dspr_(uplo, n, alpha, x, incx, ap, uplo_len)
char *uplo;
integer *n;
doublereal *alpha, *x;
integer *incx;
doublereal *ap;
ftnlen uplo_len;
{
     
    integer i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, k;
    extern logical lsame_();
    static integer kk, ix, jx, kx;
    extern   int xerbla_();
    --ap;
    --x;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (*n < 0) {
	info = 2;
    } else if (*incx == 0) {
	info = 5;
    }
    if (info != 0) {
	xerbla_("DSPR  ", &info, 6L);
	return 0;
    }

 

    if (*n == 0 || *alpha == 0.) {
	return 0;
    }

 

    if (*incx <= 0) {
	kx = 1 - (*n - 1) * *incx;
    } else if (*incx != 1) {
	kx = 1;
    }

 

 

    kk = 1;
    if (lsame_(uplo, "U", 1L, 1L)) {

 

	if (*incx == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[j] != 0.) {
		    temp = *alpha * x[j];
		    k = kk;
		    i__2 = j;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			ap[k] += x[i__] * temp;
			++k;
 
		    }
		}
		kk += j;
 
	    }
	} else {
	    jx = kx;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0.) {
		    temp = *alpha * x[jx];
		    ix = kx;
		    i__2 = kk + j - 1;
		    for (k = kk; k <= i__2; ++k) {
			ap[k] += x[ix] * temp;
			ix += *incx;
 
		    }
		}
		jx += *incx;
		kk += j;
 
	    }
	}
    } else {

 

	if (*incx == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[j] != 0.) {
		    temp = *alpha * x[j];
		    k = kk;
		    i__2 = *n;
		    for (i__ = j; i__ <= i__2; ++i__) {
			ap[k] += x[i__] * temp;
			++k;
 
		    }
		}
		kk = kk + *n - j + 1;
 
	    }
	} else {
	    jx = kx;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0.) {
		    temp = *alpha * x[jx];
		    ix = jx;
		    i__2 = kk + *n - j;
		    for (k = kk; k <= i__2; ++k) {
			ap[k] += x[ix] * temp;
			ix += *incx;
 
		    }
		}
		jx += *incx;
		kk = kk + *n - j + 1;
 
	    }
	}
    }

    return 0;

 

}  

  int dspr2_(uplo, n, alpha, x, incx, y, incy, ap, uplo_len)
char *uplo;
integer *n;
doublereal *alpha, *x;
integer *incx;
doublereal *y;
integer *incy;
doublereal *ap;
ftnlen uplo_len;
{
     
    integer i__1, i__2;

     
    static integer info;
    static doublereal temp1, temp2;
    static integer i__, j, k;
    extern logical lsame_();
    static integer kk, ix, iy, jx, jy, kx, ky;
    extern   int xerbla_();
     
    --ap;
    --y;
    --x;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (*n < 0) {
	info = 2;
    } else if (*incx == 0) {
	info = 5;
    } else if (*incy == 0) {
	info = 7;
    }
    if (info != 0) {
	xerbla_("DSPR2 ", &info, 6L);
	return 0;
    }

 

    if (*n == 0 || *alpha == 0.) {
	return 0;
    }

 

 

    if (*incx != 1 || *incy != 1) {
	if (*incx > 0) {
	    kx = 1;
	} else {
	    kx = 1 - (*n - 1) * *incx;
	}
	if (*incy > 0) {
	    ky = 1;
	} else {
	    ky = 1 - (*n - 1) * *incy;
	}
	jx = kx;
	jy = ky;
    }

 

 

    kk = 1;
    if (lsame_(uplo, "U", 1L, 1L)) {

 

	if (*incx == 1 && *incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[j] != 0. || y[j] != 0.) {
		    temp1 = *alpha * y[j];
		    temp2 = *alpha * x[j];
		    k = kk;
		    i__2 = j;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
			++k;
 
		    }
		}
		kk += j;
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0. || y[jy] != 0.) {
		    temp1 = *alpha * y[jy];
		    temp2 = *alpha * x[jx];
		    ix = kx;
		    iy = ky;
		    i__2 = kk + j - 1;
		    for (k = kk; k <= i__2; ++k) {
			ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
			ix += *incx;
			iy += *incy;
 
		    }
		}
		jx += *incx;
		jy += *incy;
		kk += j;
 
	    }
	}
    } else {

 

	if (*incx == 1 && *incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[j] != 0. || y[j] != 0.) {
		    temp1 = *alpha * y[j];
		    temp2 = *alpha * x[j];
		    k = kk;
		    i__2 = *n;
		    for (i__ = j; i__ <= i__2; ++i__) {
			ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
			++k;
 
		    }
		}
		kk = kk + *n - j + 1;
 
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		if (x[jx] != 0. || y[jy] != 0.) {
		    temp1 = *alpha * y[jy];
		    temp2 = *alpha * x[jx];
		    ix = jx;
		    iy = jy;
		    i__2 = kk + *n - j;
		    for (k = kk; k <= i__2; ++k) {
			ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
			ix += *incx;
			iy += *incy;
 
		    }
		}
		jx += *incx;
		jy += *incy;
		kk = kk + *n - j + 1;
 
	    }
	}
    }

    return 0;

 

}  

  int dsptrd_(uplo, n, ap, d__, e, tau, info, uplo_len)
char *uplo;
integer *n;
doublereal *ap, *d__, *e, *tau;
integer *info;
ftnlen uplo_len;
{
     
    integer i__1, i__2;

     
    extern doublereal ddot_();
    static doublereal taui;
    extern   int dspr2_();
    static integer i__;
    static doublereal alpha;
    extern logical lsame_();
    extern   int daxpy_(), dspmv_();
    static integer i1;
    static logical upper;
    static integer ii;
    extern   int dlarfg_(), xerbla_();
    static integer i1i1;
    --tau;
    --e;
    --d__;
    --ap;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPTRD", &i__1, 6L);
	return 0;
    }

 

    if (*n <= 0) {
	return 0;
    }

    if (upper) {

 
 

	i1 = *n * (*n - 1) / 2 + 1;
	for (i__ = *n - 1; i__ >= 1; --i__) {

 

 

	    dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
	    e[i__] = ap[i1 + i__ - 1];

	    if (taui != 0.) {

 

		ap[i1 + i__ - 1] = 1.;

 


		dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b61, &
			tau[1], &c__1, 1L);

 

		alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], &
			c__1);
		daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);

 

 

		dspr2_(uplo, &i__, &c_b418, &ap[i1], &c__1, &tau[1], &c__1, &
			ap[1], 1L);

		ap[i1 + i__ - 1] = e[i__];
	    }
	    d__[i__ + 1] = ap[i1 + i__];
	    tau[i__] = taui;
	    i1 -= i__;
 
	}
	d__[1] = ap[1];
    } else {

 
 

	ii = 1;
	i__1 = *n - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i1i1 = ii + *n - i__ + 1;

 

 

	    i__2 = *n - i__;
	    dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
	    e[i__] = ap[ii + 1];

	    if (taui != 0.) {

 


		ap[ii + 1] = 1.;

 


		i__2 = *n - i__;
		dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
			c_b61, &tau[i__], &c__1, 1L);

 

		i__2 = *n - i__;
		alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii + 
			1], &c__1);
		i__2 = *n - i__;
		daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);

 

 

		i__2 = *n - i__;
		dspr2_(uplo, &i__2, &c_b418, &ap[ii + 1], &c__1, &tau[i__], &
			c__1, &ap[i1i1], 1L);

		ap[ii + 1] = e[i__];
	    }
	    d__[i__] = ap[ii];
	    tau[i__] = taui;
	    ii = i1i1;
 
	}
	d__[*n] = ap[ii];
    }

    return 0;

 

}  

  int dsptrf_(uplo, n, ap, ipiv, info, uplo_len)
char *uplo;
integer *n;
doublereal *ap;
integer *ipiv, *info;
ftnlen uplo_len;
{
     
    integer i__1;
    doublereal d__1, d__2, d__3;

     
    double sqrt();

     
    static integer imax, jmax;
    extern   int drot_(), dspr_();
    static doublereal c__;
    static integer j, k;
    static doublereal s, t, alpha;
    extern   int dscal_();
    extern logical lsame_();
    extern   int dswap_();
    static integer kstep;
    static logical upper;
    static doublereal r1, r2;
    extern   int dlaev2_();
    static integer kc, kk, kp;
    static doublereal absakk;
    static integer kx;
    extern integer idamax_();
    extern   int xerbla_();
    static doublereal colmax, rowmax;
    static integer knc, kpc, npp;
     
    --ipiv;
    --ap;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPTRF", &i__1, 6L);
	return 0;
    }

 

    alpha = (sqrt(17.) + 1.) / 8.;

    if (upper) {

 

 

 

	k = *n;
	kc = (*n - 1) * *n / 2 + 1;
L10:
	knc = kc;

 

	if (k < 1) {
	    goto L70;
	}
	kstep = 1;

 
 

	absakk = (d__1 = ap[kc + k - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

 

 

	if (k > 1) {
	    i__1 = k - 1;
	    imax = idamax_(&i__1, &ap[kc], &c__1);
	    colmax = (d__1 = ap[kc + imax - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	} else {
	    colmax = 0.;
	}

	if ((( absakk ) >= ( colmax ) ? ( absakk ) : ( colmax ))  == 0.) {

 

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	} else {
	    if (absakk >= alpha * colmax) {

 

		kp = k;
	    } else {

 

 


		rowmax = 0.;
		jmax = imax;
		kx = imax * (imax + 1) / 2 + imax;
		i__1 = k;
		for (j = imax + 1; j <= i__1; ++j) {
		    if ((d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > rowmax) {
			rowmax = (d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
			jmax = j;
		    }
		    kx += j;
 
		}
		kpc = (imax - 1) * imax / 2 + 1;
		if (imax > 1) {
		    i__1 = imax - 1;
		    jmax = idamax_(&i__1, &ap[kpc], &c__1);
 
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], (( 
			    d__1 ) >= 0 ? (  			    d__1 ) : -(  			    d__1 )) );
		    rowmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
		}

		if (absakk >= alpha * colmax * (colmax / rowmax)) {

 


		    kp = k;
		} else if ((d__1 = ap[kpc + imax - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= alpha * 
			rowmax) {

 

 

		    kp = imax;
		} else {

 

 

		    kp = imax;
		    kstep = 2;
		}
	    }

	    kk = k - kstep + 1;
	    if (kstep == 2) {
		knc = knc - k + 1;
	    }
	    if (kp != kk) {

 

 

		i__1 = kp - 1;
		dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
		kx = kpc + kp - 1;
		i__1 = kk - 1;
		for (j = kp + 1; j <= i__1; ++j) {
		    kx = kx + j - 1;
		    t = ap[knc + j - 1];
		    ap[knc + j - 1] = ap[kx];
		    ap[kx] = t;
 
		}
		t = ap[knc + kk - 1];
		ap[knc + kk - 1] = ap[kpc + kp - 1];
		ap[kpc + kp - 1] = t;
		if (kstep == 2) {
		    t = ap[kc + k - 2];
		    ap[kc + k - 2] = ap[kc + kp - 1];
		    ap[kc + kp - 1] = t;
		}
	    }

 

	    if (kstep == 1) {

 

 

 

 


 


		r1 = 1. / ap[kc + k - 1];
		i__1 = k - 1;
		d__1 = -r1;
		dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], 1L);

 

		i__1 = k - 1;
		dscal_(&i__1, &r1, &ap[kc], &c__1);
	    } else {

 


 

 

 

 


 

 


 

 

		dlaev2_(&ap[kc - 1], &ap[kc + k - 2], &ap[kc + k - 1], &r1, &
			r2, &c__, &s);
		r1 = 1. / r1;
		r2 = 1. / r2;
		i__1 = k - 2;
		drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &s);
		i__1 = k - 2;
		d__1 = -r1;
		dspr_(uplo, &i__1, &d__1, &ap[knc], &c__1, &ap[1], 1L);
		i__1 = k - 2;
		d__1 = -r2;
		dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], 1L);

 

		i__1 = k - 2;
		dscal_(&i__1, &r1, &ap[knc], &c__1);
		i__1 = k - 2;
		dscal_(&i__1, &r2, &ap[kc], &c__1);
		i__1 = k - 2;
		d__1 = -s;
		drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &d__1);
	    }
	}

 

	if (kstep == 1) {
	    ipiv[k] = kp;
	} else {
	    ipiv[k] = -kp;
	    ipiv[k - 1] = -kp;
	}

 

	k -= kstep;
	kc = knc - k;
	goto L10;

    } else {

 

 

 

	k = 1;
	kc = 1;
	npp = *n * (*n + 1) / 2;
L40:
	knc = kc;

 

	if (k > *n) {
	    goto L70;
	}
	kstep = 1;

 
 

	absakk = (d__1 = ap[kc], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

 

 

	if (k < *n) {
	    i__1 = *n - k;
	    imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
	    colmax = (d__1 = ap[kc + imax - k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	} else {
	    colmax = 0.;
	}

	if ((( absakk ) >= ( colmax ) ? ( absakk ) : ( colmax ))  == 0.) {

 

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	} else {
	    if (absakk >= alpha * colmax) {

 

		kp = k;
	    } else {

 

 


		rowmax = 0.;
		kx = kc + imax - k;
		i__1 = imax - 1;
		for (j = k; j <= i__1; ++j) {
		    if ((d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > rowmax) {
			rowmax = (d__1 = ap[kx], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
			jmax = j;
		    }
		    kx = kx + *n - j;
 
		}
		kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
		if (imax < *n) {
		    i__1 = *n - imax;
		    jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
 
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], (( 
			    d__1 ) >= 0 ? (  			    d__1 ) : -(  			    d__1 )) );
		    rowmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
		}

		if (absakk >= alpha * colmax * (colmax / rowmax)) {

 


		    kp = k;
		} else if ((d__1 = ap[kpc], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= alpha * rowmax) {

 

 

		    kp = imax;
		} else {

 

 

		    kp = imax;
		    kstep = 2;
		}
	    }

	    kk = k + kstep - 1;
	    if (kstep == 2) {
		knc = knc + *n - k + 1;
	    }
	    if (kp != kk) {

 

 

		if (kp < *n) {
		    i__1 = *n - kp;
		    dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
			     &c__1);
		}
		kx = knc + kp - kk;
		i__1 = kp - 1;
		for (j = kk + 1; j <= i__1; ++j) {
		    kx = kx + *n - j + 1;
		    t = ap[knc + j - kk];
		    ap[knc + j - kk] = ap[kx];
		    ap[kx] = t;
 
		}
		t = ap[knc];
		ap[knc] = ap[kpc];
		ap[kpc] = t;
		if (kstep == 2) {
		    t = ap[kc + 1];
		    ap[kc + 1] = ap[kc + kp - k];
		    ap[kc + kp - k] = t;
		}
	    }

 

	    if (kstep == 1) {

 

 

 

		if (k < *n) {

 


 


		    r1 = 1. / ap[kc];
		    i__1 = *n - k;
		    d__1 = -r1;
		    dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n 
			    - k + 1], 1L);

 

		    i__1 = *n - k;
		    dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
		}
	    } else {

 


 

 

 

		if (k < *n - 1) {

 


 

 


 

 

		    dlaev2_(&ap[kc], &ap[kc + 1], &ap[knc], &r1, &r2, &c__, &
			    s);
		    r1 = 1. / r1;
		    r2 = 1. / r2;
		    i__1 = *n - k - 1;
		    drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
			    c__, &s);
		    i__1 = *n - k - 1;
		    d__1 = -r1;
		    dspr_(uplo, &i__1, &d__1, &ap[kc + 2], &c__1, &ap[knc + *
			    n - k], 1L);
		    i__1 = *n - k - 1;
		    d__1 = -r2;
		    dspr_(uplo, &i__1, &d__1, &ap[knc + 1], &c__1, &ap[knc + *
			    n - k], 1L);

 


		    i__1 = *n - k - 1;
		    dscal_(&i__1, &r1, &ap[kc + 2], &c__1);
		    i__1 = *n - k - 1;
		    dscal_(&i__1, &r2, &ap[knc + 1], &c__1);
		    i__1 = *n - k - 1;
		    d__1 = -s;
		    drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
			    c__, &d__1);
		}
	    }
	}

 

	if (kstep == 1) {
	    ipiv[k] = kp;
	} else {
	    ipiv[k] = -kp;
	    ipiv[k + 1] = -kp;
	}

 

	k += kstep;
	kc = knc + *n - k + 2;
	goto L40;

    }

L70:
    return 0;

 

}  

  int dsteqr_(compz, n, d__, e, z__, ldz, work, info, 
	compz_len)
char *compz;
integer *n;
doublereal *d__, *e, *z__;
integer *ldz;
doublereal *work;
integer *info;
ftnlen compz_len;
{
     
    integer z_dim1, z_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    static integer lend, jtot;
    extern   int dlae2_();
    static doublereal b, c__, f, g;
    static integer i__, j, k, l, m;
    static doublereal p, r__, s;
    extern logical lsame_();
    extern   int dlasr_();
    static doublereal anorm;
    extern   int dswap_();
    static integer l1;
    extern   int dlaev2_();
    static integer lendm1, lendp1;
    extern doublereal dlapy2_();
    static integer ii;
    extern doublereal dlamch_();
    static integer mm, iscale;
    extern   int dlascl_(), dlaset_();
    static doublereal safmin;
    extern   int dlartg_();
    static doublereal safmax;
    extern   int xerbla_();
    extern doublereal dlanst_();
    extern   int dlasrt_();
    static integer lendsv;
    static doublereal ssfmin;
    static integer nmaxit, icompz;
    static doublereal ssfmax;
    static integer lm1, mm1, nm1;
    static doublereal rt1, rt2, eps;
    static integer lsv;
    static doublereal tst, eps2;
     
    --d__;
    --e;
    z_dim1 = *ldz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --work;

     
    *info = 0;

    if (lsame_(compz, "N", 1L, 1L)) {
	icompz = 0;
    } else if (lsame_(compz, "V", 1L, 1L)) {
	icompz = 1;
    } else if (lsame_(compz, "I", 1L, 1L)) {
	icompz = 2;
    } else {
	icompz = -1;
    }
    if (icompz < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*ldz < 1 || icompz > 0 && *ldz < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	*info = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSTEQR", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	if (icompz == 2) {
	    z__[z_dim1 + 1] = 1.;
	}
	return 0;
    }

 

    eps = dlamch_("E", 1L);
 
    d__1 = eps;
    eps2 = d__1 * d__1;
    safmin = dlamch_("S", 1L);
    safmax = 1. / safmin;
    ssfmax = sqrt(safmax) / 3.;
    ssfmin = sqrt(safmin) / eps2;

 
 

    if (icompz == 2) {
	dlaset_("Full", n, n, &c_b61, &c_b89, &z__[z_offset], ldz, 4L);
    }

    nmaxit = *n * 30;
    jtot = 0;

 
 
 

    l1 = 1;
    nm1 = *n - 1;

L10:
    if (l1 > *n) {
	goto L160;
    }
    if (l1 > 1) {
	e[l1 - 1] = 0.;
    }
    if (l1 <= nm1) {
	i__1 = nm1;
	for (m = l1; m <= i__1; ++m) {
	    tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (tst == 0.) {
		goto L30;
	    }
	    if (tst <= sqrt((d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) * sqrt((d__2 = d__[m 
		    + 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * eps) {
		e[m] = 0.;
		goto L30;
	    }
 
	}
    }
    m = *n;

L30:
    l = l1;
    lsv = l;
    lend = m;
    lendsv = lend;
    l1 = m + 1;
    if (lend == l) {
	goto L10;
    }

 

    i__1 = lend - l + 1;
    anorm = dlanst_("I", &i__1, &d__[l], &e[l], 1L);
    iscale = 0;
    if (anorm == 0.) {
	goto L10;
    }
    if (anorm > ssfmax) {
	iscale = 1;
	i__1 = lend - l + 1;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
		info, 1L);
	i__1 = lend - l;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
		info, 1L);
    } else if (anorm < ssfmin) {
	iscale = 2;
	i__1 = lend - l + 1;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
		info, 1L);
	i__1 = lend - l;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
		info, 1L);
    }

 

    if ((d__1 = d__[lend], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = d__[l], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	lend = lsv;
	l = lendsv;
    }

    if (lend > l) {

 

 

L40:
	if (l != lend) {
	    lendm1 = lend - 1;
	    i__1 = lendm1;
	    for (m = l; m <= i__1; ++m) {
 
		d__2 = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		tst = d__2 * d__2;
		if (tst <= eps2 * (d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (d__2 = d__[m 
			+ 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + safmin) {
		    goto L60;
		}
 
	    }
	}

	m = lend;

L60:
	if (m < lend) {
	    e[m] = 0.;
	}
	p = d__[l];
	if (m == l) {
	    goto L80;
	}

 
 

	if (m == l + 1) {
	    if (icompz > 0) {
		dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
		work[l] = c__;
		work[*n - 1 + l] = s;
		dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
			z__[l * z_dim1 + 1], ldz, 1L, 1L, 1L);
	    } else {
		dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
	    }
	    d__[l] = rt1;
	    d__[l + 1] = rt2;
	    e[l] = 0.;
	    l += 2;
	    if (l <= lend) {
		goto L40;
	    }
	    goto L140;
	}

	if (jtot == nmaxit) {
	    goto L140;
	}
	++jtot;

 

	g = (d__[l + 1] - p) / (e[l] * 2.);
	r__ = dlapy2_(&g, &c_b89);
	g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));

	s = 1.;
	c__ = 1.;
	p = 0.;

 

	mm1 = m - 1;
	i__1 = l;
	for (i__ = mm1; i__ >= i__1; --i__) {
	    f = s * e[i__];
	    b = c__ * e[i__];
	    dlartg_(&g, &f, &c__, &s, &r__);
	    if (i__ != m - 1) {
		e[i__ + 1] = r__;
	    }
	    g = d__[i__ + 1] - p;
	    r__ = (d__[i__] - g) * s + c__ * 2. * b;
	    p = s * r__;
	    d__[i__ + 1] = g + p;
	    g = c__ * r__ - b;

 

	    if (icompz > 0) {
		work[i__] = c__;
		work[*n - 1 + i__] = -s;
	    }

 
	}

 

	if (icompz > 0) {
	    mm = m - l + 1;
	    dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l 
		    * z_dim1 + 1], ldz, 1L, 1L, 1L);
	}

	d__[l] -= p;
	e[l] = g;
	goto L40;

 

L80:
	d__[l] = p;

	++l;
	if (l <= lend) {
	    goto L40;
	}
	goto L140;

    } else {

 

 

L90:
	if (l != lend) {
	    lendp1 = lend + 1;
	    i__1 = lendp1;
	    for (m = l; m >= i__1; --m) {
 
		d__2 = (d__1 = e[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		tst = d__2 * d__2;
		if (tst <= eps2 * (d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (d__2 = d__[m 
			- 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + safmin) {
		    goto L110;
		}
 
	    }
	}

	m = lend;

L110:
	if (m > lend) {
	    e[m - 1] = 0.;
	}
	p = d__[l];
	if (m == l) {
	    goto L130;
	}

 
 

	if (m == l - 1) {
	    if (icompz > 0) {
		dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
			;
		work[m] = c__;
		work[*n - 1 + m] = s;
		dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
			z__[(l - 1) * z_dim1 + 1], ldz, 1L, 1L, 1L);
	    } else {
		dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
	    }
	    d__[l - 1] = rt1;
	    d__[l] = rt2;
	    e[l - 1] = 0.;
	    l += -2;
	    if (l >= lend) {
		goto L90;
	    }
	    goto L140;
	}

	if (jtot == nmaxit) {
	    goto L140;
	}
	++jtot;

 

	g = (d__[l - 1] - p) / (e[l - 1] * 2.);
	r__ = dlapy2_(&g, &c_b89);
	g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));

	s = 1.;
	c__ = 1.;
	p = 0.;

 

	lm1 = l - 1;
	i__1 = lm1;
	for (i__ = m; i__ <= i__1; ++i__) {
	    f = s * e[i__];
	    b = c__ * e[i__];
	    dlartg_(&g, &f, &c__, &s, &r__);
	    if (i__ != m) {
		e[i__ - 1] = r__;
	    }
	    g = d__[i__] - p;
	    r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
	    p = s * r__;
	    d__[i__] = g + p;
	    g = c__ * r__ - b;

 

	    if (icompz > 0) {
		work[i__] = c__;
		work[*n - 1 + i__] = s;
	    }

 
	}

 

	if (icompz > 0) {
	    mm = l - m + 1;
	    dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m 
		    * z_dim1 + 1], ldz, 1L, 1L, 1L);
	}

	d__[l] -= p;
	e[lm1] = g;
	goto L90;

 

L130:
	d__[l] = p;

	--l;
	if (l >= lend) {
	    goto L90;
	}
	goto L140;

    }

 

L140:
    if (iscale == 1) {
	i__1 = lendsv - lsv + 1;
	dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info, 1L);
	i__1 = lendsv - lsv;
	dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, 
		info, 1L);
    } else if (iscale == 2) {
	i__1 = lendsv - lsv + 1;
	dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info, 1L);
	i__1 = lendsv - lsv;
	dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, 
		info, 1L);
    }

 
 

    if (jtot < nmaxit) {
	goto L10;
    }
    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (e[i__] != 0.) {
	    ++(*info);
	}
 
    }
    goto L190;

 

L160:
    if (icompz == 0) {

 

	dlasrt_("I", n, &d__[1], info, 1L);

    } else {

 

	i__1 = *n;
	for (ii = 2; ii <= i__1; ++ii) {
	    i__ = ii - 1;
	    k = i__;
	    p = d__[i__];
	    i__2 = *n;
	    for (j = ii; j <= i__2; ++j) {
		if (d__[j] < p) {
		    k = j;
		    p = d__[j];
		}
 
	    }
	    if (k != i__) {
		d__[k] = d__[i__];
		d__[i__] = p;
		dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
			 &c__1);
	    }
 
	}
    }

L190:
    return 0;

 

}  

  int dsterf_(n, d__, e, info)
integer *n;
doublereal *d__, *e;
integer *info;
{
     
    integer i__1;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    static doublereal oldc;
    static integer lend, jtot;
    extern   int dlae2_();
    static doublereal c__;
    static integer i__, l, m;
    static doublereal p, gamma, r__, s, alpha, sigma, anorm;
    static integer l1, lendm1, lendp1;
    extern doublereal dlapy2_();
    static doublereal bb;
    extern doublereal dlamch_();
    static integer iscale;
    extern   int dlascl_();
    static doublereal oldgam, safmin;
    extern   int xerbla_();
    static doublereal safmax;
    extern doublereal dlanst_();
    extern   int dlasrt_();
    static integer lendsv;
    static doublereal ssfmin;
    static integer nmaxit;
    static doublereal ssfmax;
    static integer lm1, mm1, nm1;
    static doublereal rt1, rt2, eps, rte;
    static integer lsv;
    static doublereal tst, eps2;
    --e;
    --d__;

     
    *info = 0;

 

    if (*n < 0) {
	*info = -1;
	i__1 = -(*info);
	xerbla_("DSTERF", &i__1, 6L);
	return 0;
    }
    if (*n <= 1) {
	return 0;
    }

 

    eps = dlamch_("E", 1L);
 
    d__1 = eps;
    eps2 = d__1 * d__1;
    safmin = dlamch_("S", 1L);
    safmax = 1. / safmin;
    ssfmax = sqrt(safmax) / 3.;
    ssfmin = sqrt(safmin) / eps2;

 

    nmaxit = *n * 30;
    sigma = 0.;
    jtot = 0;

 
 
 

    l1 = 1;
    nm1 = *n - 1;

L10:
    if (l1 > *n) {
	goto L170;
    }
    if (l1 > 1) {
	e[l1 - 1] = 0.;
    }
    if (l1 <= nm1) {
	i__1 = nm1;
	for (m = l1; m <= i__1; ++m) {
	    tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (tst == 0.) {
		goto L30;
	    }
	    if (tst <= sqrt((d__1 = d__[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) * sqrt((d__2 = d__[m 
		    + 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * eps) {
		e[m] = 0.;
		goto L30;
	    }
 
	}
    }
    m = *n;

L30:
    l = l1;
    lsv = l;
    lend = m;
    lendsv = lend;
    l1 = m + 1;
    if (lend == l) {
	goto L10;
    }

 

    i__1 = lend - l + 1;
    anorm = dlanst_("I", &i__1, &d__[l], &e[l], 1L);
    iscale = 0;
    if (anorm > ssfmax) {
	iscale = 1;
	i__1 = lend - l + 1;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
		info, 1L);
	i__1 = lend - l;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
		info, 1L);
    } else if (anorm < ssfmin) {
	iscale = 2;
	i__1 = lend - l + 1;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
		info, 1L);
	i__1 = lend - l;
	dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
		info, 1L);
    }

    i__1 = lend - 1;
    for (i__ = l; i__ <= i__1; ++i__) {
 
	d__1 = e[i__];
	e[i__] = d__1 * d__1;
 
    }

 

    if ((d__1 = d__[lend], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = d__[l], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	lend = lsv;
	l = lendsv;
    }

    if (lend >= l) {

 

 

L50:
	if (l != lend) {
	    lendm1 = lend - 1;
	    i__1 = lendm1;
	    for (m = l; m <= i__1; ++m) {
		tst = (d__1 = e[m], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (tst <= eps2 * (d__1 = d__[m] * d__[m + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) {
		    goto L70;
		}
 
	    }
	}

	m = lend;

L70:
	if (m < lend) {
	    e[m] = 0.;
	}
	p = d__[l];
	if (m == l) {
	    goto L90;
	}

 
 

	if (m == l + 1) {
	    rte = sqrt(e[l]);
	    dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
	    d__[l] = rt1;
	    d__[l + 1] = rt2;
	    e[l] = 0.;
	    l += 2;
	    if (l <= lend) {
		goto L50;
	    }
	    goto L150;
	}

	if (jtot == nmaxit) {
	    goto L150;
	}
	++jtot;

 

	rte = sqrt(e[l]);
	sigma = (d__[l + 1] - p) / (rte * 2.);
	r__ = dlapy2_(&sigma, &c_b89);
	sigma = p - rte / (sigma + d_sign(&r__, &sigma));

	c__ = 1.;
	s = 0.;
	gamma = d__[m] - sigma;
	p = gamma * gamma;

 

	mm1 = m - 1;
	i__1 = l;
	for (i__ = mm1; i__ >= i__1; --i__) {
	    bb = e[i__];
	    r__ = p + bb;
	    if (i__ != m - 1) {
		e[i__ + 1] = s * r__;
	    }
	    oldc = c__;
	    c__ = p / r__;
	    s = bb / r__;
	    oldgam = gamma;
	    alpha = d__[i__];
	    gamma = c__ * (alpha - sigma) - s * oldgam;
	    d__[i__ + 1] = oldgam + (alpha - gamma);
	    if (c__ != 0.) {
		p = gamma * gamma / c__;
	    } else {
		p = oldc * bb;
	    }
 
	}

	e[l] = s * p;
	d__[l] = sigma + gamma;
	goto L50;

 

L90:
	d__[l] = p;

	++l;
	if (l <= lend) {
	    goto L50;
	}
	goto L150;

    } else {

 

 

L100:
	if (l != lend) {
	    lendp1 = lend + 1;
	    i__1 = lendp1;
	    for (m = l; m >= i__1; --m) {
		tst = (d__1 = e[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (tst <= eps2 * (d__1 = d__[m] * d__[m - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) )) {
		    goto L120;
		}
 
	    }
	}

	m = lend;

L120:
	if (m > lend) {
	    e[m - 1] = 0.;
	}
	p = d__[l];
	if (m == l) {
	    goto L140;
	}

 
 

	if (m == l - 1) {
	    rte = sqrt(e[l - 1]);
	    dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
	    d__[l] = rt1;
	    d__[l - 1] = rt2;
	    e[l - 1] = 0.;
	    l += -2;
	    if (l >= lend) {
		goto L100;
	    }
	    goto L150;
	}

	if (jtot == nmaxit) {
	    goto L150;
	}
	++jtot;

 

	rte = sqrt(e[l - 1]);
	sigma = (d__[l - 1] - p) / (rte * 2.);
	r__ = dlapy2_(&sigma, &c_b89);
	sigma = p - rte / (sigma + d_sign(&r__, &sigma));

	c__ = 1.;
	s = 0.;
	gamma = d__[m] - sigma;
	p = gamma * gamma;

 

	lm1 = l - 1;
	i__1 = lm1;
	for (i__ = m; i__ <= i__1; ++i__) {
	    bb = e[i__];
	    r__ = p + bb;
	    if (i__ != m) {
		e[i__ - 1] = s * r__;
	    }
	    oldc = c__;
	    c__ = p / r__;
	    s = bb / r__;
	    oldgam = gamma;
	    alpha = d__[i__ + 1];
	    gamma = c__ * (alpha - sigma) - s * oldgam;
	    d__[i__] = oldgam + (alpha - gamma);
	    if (c__ != 0.) {
		p = gamma * gamma / c__;
	    } else {
		p = oldc * bb;
	    }
 
	}

	e[lm1] = s * p;
	d__[l] = sigma + gamma;
	goto L100;

 

L140:
	d__[l] = p;

	--l;
	if (l >= lend) {
	    goto L100;
	}
	goto L150;

    }

 

L150:
    if (iscale == 1) {
	i__1 = lendsv - lsv + 1;
	dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info, 1L);
    }
    if (iscale == 2) {
	i__1 = lendsv - lsv + 1;
	dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info, 1L);
    }

 
 

    if (jtot == nmaxit) {
	i__1 = *n - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (e[i__] != 0.) {
		++(*info);
	    }
 
	}
	return 0;
    }
    goto L10;

 

L170:
    dlasrt_("I", n, &d__[1], info, 1L);

    return 0;

 

}  

  int dtpmv_(uplo, trans, diag, n, ap, x, incx, uplo_len, 
	trans_len, diag_len)
char *uplo, *trans, *diag;
integer *n;
doublereal *ap, *x;
integer *incx;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
{
     
    integer i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, k;
    extern logical lsame_();
    static integer kk, ix, jx, kx;
    extern   int xerbla_();
    static logical nounit;
     
    --x;
    --ap;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) &&
	     ! lsame_(trans, "C", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*incx == 0) {
	info = 7;
    }
    if (info != 0) {
	xerbla_("DTPMV ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    nounit = lsame_(diag, "N", 1L, 1L);

 
 

    if (*incx <= 0) {
	kx = 1 - (*n - 1) * *incx;
    } else if (*incx != 1) {
	kx = 1;
    }

 
 

    if (lsame_(trans, "N", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    kk = 1;
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[j] != 0.) {
			temp = x[j];
			k = kk;
			i__2 = j - 1;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    x[i__] += temp * ap[k];
			    ++k;
 
			}
			if (nounit) {
			    x[j] *= ap[kk + j - 1];
			}
		    }
		    kk += j;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[jx] != 0.) {
			temp = x[jx];
			ix = kx;
			i__2 = kk + j - 2;
			for (k = kk; k <= i__2; ++k) {
			    x[ix] += temp * ap[k];
			    ix += *incx;
 
			}
			if (nounit) {
			    x[jx] *= ap[kk + j - 1];
			}
		    }
		    jx += *incx;
		    kk += j;
 
		}
	    }
	} else {
	    kk = *n * (*n + 1) / 2;
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    if (x[j] != 0.) {
			temp = x[j];
			k = kk;
			i__1 = j + 1;
			for (i__ = *n; i__ >= i__1; --i__) {
			    x[i__] += temp * ap[k];
			    --k;
 
			}
			if (nounit) {
			    x[j] *= ap[kk - *n + j];
			}
		    }
		    kk -= *n - j + 1;
 
		}
	    } else {
		kx += (*n - 1) * *incx;
		jx = kx;
		for (j = *n; j >= 1; --j) {
		    if (x[jx] != 0.) {
			temp = x[jx];
			ix = kx;
			i__1 = kk - (*n - (j + 1));
			for (k = kk; k >= i__1; --k) {
			    x[ix] += temp * ap[k];
			    ix -= *incx;
 
			}
			if (nounit) {
			    x[jx] *= ap[kk - *n + j];
			}
		    }
		    jx -= *incx;
		    kk -= *n - j + 1;
 
		}
	    }
	}
    } else {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    kk = *n * (*n + 1) / 2;
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    temp = x[j];
		    if (nounit) {
			temp *= ap[kk];
		    }
		    k = kk - 1;
		    for (i__ = j - 1; i__ >= 1; --i__) {
			temp += ap[k] * x[i__];
			--k;
 
		    }
		    x[j] = temp;
		    kk -= j;
 
		}
	    } else {
		jx = kx + (*n - 1) * *incx;
		for (j = *n; j >= 1; --j) {
		    temp = x[jx];
		    ix = jx;
		    if (nounit) {
			temp *= ap[kk];
		    }
		    i__1 = kk - j + 1;
		    for (k = kk - 1; k >= i__1; --k) {
			ix -= *incx;
			temp += ap[k] * x[ix];
 
		    }
		    x[jx] = temp;
		    jx -= *incx;
		    kk -= j;
 
		}
	    }
	} else {
	    kk = 1;
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[j];
		    if (nounit) {
			temp *= ap[kk];
		    }
		    k = kk + 1;
		    i__2 = *n;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
			temp += ap[k] * x[i__];
			++k;
 
		    }
		    x[j] = temp;
		    kk += *n - j + 1;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[jx];
		    ix = jx;
		    if (nounit) {
			temp *= ap[kk];
		    }
		    i__2 = kk + *n - j;
		    for (k = kk + 1; k <= i__2; ++k) {
			ix += *incx;
			temp += ap[k] * x[ix];
 
		    }
		    x[jx] = temp;
		    jx += *incx;
		    kk += *n - j + 1;
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dtpsv_(uplo, trans, diag, n, ap, x, incx, uplo_len, 
	trans_len, diag_len)
char *uplo, *trans, *diag;
integer *n;
doublereal *ap, *x;
integer *incx;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
{
     
    integer i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, k;
    extern logical lsame_();
    static integer kk, ix, jx, kx;
    extern   int xerbla_();
    static logical nounit;
     
    --x;
    --ap;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) &&
	     ! lsame_(trans, "C", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*incx == 0) {
	info = 7;
    }
    if (info != 0) {
	xerbla_("DTPSV ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    nounit = lsame_(diag, "N", 1L, 1L);

 
 

    if (*incx <= 0) {
	kx = 1 - (*n - 1) * *incx;
    } else if (*incx != 1) {
	kx = 1;
    }

 
 

    if (lsame_(trans, "N", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    kk = *n * (*n + 1) / 2;
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    if (x[j] != 0.) {
			if (nounit) {
			    x[j] /= ap[kk];
			}
			temp = x[j];
			k = kk - 1;
			for (i__ = j - 1; i__ >= 1; --i__) {
			    x[i__] -= temp * ap[k];
			    --k;
 
			}
		    }
		    kk -= j;
 
		}
	    } else {
		jx = kx + (*n - 1) * *incx;
		for (j = *n; j >= 1; --j) {
		    if (x[jx] != 0.) {
			if (nounit) {
			    x[jx] /= ap[kk];
			}
			temp = x[jx];
			ix = jx;
			i__1 = kk - j + 1;
			for (k = kk - 1; k >= i__1; --k) {
			    ix -= *incx;
			    x[ix] -= temp * ap[k];
 
			}
		    }
		    jx -= *incx;
		    kk -= j;
 
		}
	    }
	} else {
	    kk = 1;
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[j] != 0.) {
			if (nounit) {
			    x[j] /= ap[kk];
			}
			temp = x[j];
			k = kk + 1;
			i__2 = *n;
			for (i__ = j + 1; i__ <= i__2; ++i__) {
			    x[i__] -= temp * ap[k];
			    ++k;
 
			}
		    }
		    kk += *n - j + 1;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[jx] != 0.) {
			if (nounit) {
			    x[jx] /= ap[kk];
			}
			temp = x[jx];
			ix = jx;
			i__2 = kk + *n - j;
			for (k = kk + 1; k <= i__2; ++k) {
			    ix += *incx;
			    x[ix] -= temp * ap[k];
 
			}
		    }
		    jx += *incx;
		    kk += *n - j + 1;
 
		}
	    }
	}
    } else {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    kk = 1;
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[j];
		    k = kk;
		    i__2 = j - 1;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp -= ap[k] * x[i__];
			++k;
 
		    }
		    if (nounit) {
			temp /= ap[kk + j - 1];
		    }
		    x[j] = temp;
		    kk += j;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[jx];
		    ix = kx;
		    i__2 = kk + j - 2;
		    for (k = kk; k <= i__2; ++k) {
			temp -= ap[k] * x[ix];
			ix += *incx;
 
		    }
		    if (nounit) {
			temp /= ap[kk + j - 1];
		    }
		    x[jx] = temp;
		    jx += *incx;
		    kk += j;
 
		}
	    }
	} else {
	    kk = *n * (*n + 1) / 2;
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    temp = x[j];
		    k = kk;
		    i__1 = j + 1;
		    for (i__ = *n; i__ >= i__1; --i__) {
			temp -= ap[k] * x[i__];
			--k;
 
		    }
		    if (nounit) {
			temp /= ap[kk - *n + j];
		    }
		    x[j] = temp;
		    kk -= *n - j + 1;
 
		}
	    } else {
		kx += (*n - 1) * *incx;
		jx = kx;
		for (j = *n; j >= 1; --j) {
		    temp = x[jx];
		    ix = kx;
		    i__1 = kk - (*n - (j + 1));
		    for (k = kk; k >= i__1; --k) {
			temp -= ap[k] * x[ix];
			ix -= *incx;
 
		    }
		    if (nounit) {
			temp /= ap[kk - *n + j];
		    }
		    x[jx] = temp;
		    jx -= *incx;
		    kk -= *n - j + 1;
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dtrcon_(norm, uplo, diag, n, a, lda, rcond, work, iwork, 
	info, norm_len, uplo_len, diag_len)
char *norm, *uplo, *diag;
integer *n;
doublereal *a;
integer *lda;
doublereal *rcond, *work;
integer *iwork, *info;
ftnlen norm_len;
ftnlen uplo_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, i__1;
    doublereal d__1;

     
    static integer kase, kase1;
    static doublereal scale;
    extern logical lsame_();
    extern   int drscl_();
    static doublereal anorm;
    static logical upper;
    static doublereal xnorm;
    extern doublereal dlamch_();
    extern   int dlacon_();
    static integer ix;
    extern integer idamax_();
    extern   int xerbla_();
    extern doublereal dlantr_();
    static doublereal ainvnm;
    extern   int dlatrs_();
    static logical onenrm;
    static char normin[1];
    static doublereal smlnum;
    static logical nounit;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --work;
    --iwork;

     
    *info = 0;
    upper = lsame_(uplo, "U", 1L, 1L);
    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", 1L, 1L);
    nounit = lsame_(diag, "N", 1L, 1L);

    if (! onenrm && ! lsame_(norm, "I", 1L, 1L)) {
	*info = -1;
    } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	*info = -2;
    } else if (! nounit && ! lsame_(diag, "U", 1L, 1L)) {
	*info = -3;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	*info = -6;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DTRCON", &i__1, 6L);
	return 0;
    }

 

    if (*n == 0) {
	*rcond = 1.;
	return 0;
    }

    *rcond = 0.;
    smlnum = dlamch_("Safe minimum", 12L) * (doublereal) (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ;

 

    anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1], 1L, 
	    1L, 1L);

 

    if (anorm > 0.) {

 

	ainvnm = 0.;
	*(unsigned char *)normin = 'N';
	if (onenrm) {
	    kase1 = 1;
	} else {
	    kase1 = 2;
	}
	kase = 0;
L10:
	dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
	if (kase != 0) {
	    if (kase == kase1) {

 

		dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], 
			lda, &work[1], &scale, &work[(*n << 1) + 1], info, 1L,
			 12L, 1L, 1L);
	    } else {

 

		dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
			 &work[1], &scale, &work[(*n << 1) + 1], info, 1L, 9L,
			 1L, 1L);
	    }
	    *(unsigned char *)normin = 'Y';

 


	    if (scale != 1.) {
		ix = idamax_(n, &work[1], &c__1);
		xnorm = (d__1 = work[ix], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		if (scale < xnorm * smlnum || scale == 0.) {
		    goto L20;
		}
		drscl_(n, &scale, &work[1], &c__1);
	    }
	    goto L10;
	}

 

	if (ainvnm != 0.) {
	    *rcond = 1. / anorm / ainvnm;
	}
    }

L20:
    return 0;

 

}  

  int dtrmm_(side, uplo, transa, diag, m, n, alpha, a, lda, b, 
	ldb, side_len, uplo_len, transa_len, diag_len)
char *side, *uplo, *transa, *diag;
integer *m, *n;
doublereal *alpha, *a;
integer *lda;
doublereal *b;
integer *ldb;
ftnlen side_len;
ftnlen uplo_len;
ftnlen transa_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, k;
    static logical lside;
    extern logical lsame_();
    static integer nrowa;
    static logical upper;
    extern   int xerbla_();
    static logical nounit;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = b_dim1 + 1;
    b -= b_offset;

     
    lside = lsame_(side, "L", 1L, 1L);
    if (lside) {
	nrowa = *m;
    } else {
	nrowa = *n;
    }
    nounit = lsame_(diag, "N", 1L, 1L);
    upper = lsame_(uplo, "U", 1L, 1L);

    info = 0;
    if (! lside && ! lsame_(side, "R", 1L, 1L)) {
	info = 1;
    } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(transa, "N", 1L, 1L) && ! lsame_(transa, "T", 1L, 1L) 
	    && ! lsame_(transa, "C", 1L, 1L)) {
	info = 3;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 4;
    } else if (*m < 0) {
	info = 5;
    } else if (*n < 0) {
	info = 6;
    } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) {
	info = 9;
    } else if (*ldb < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 11;
    }
    if (info != 0) {
	xerbla_("DTRMM ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

 

    if (*alpha == 0.) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		b[i__ + j * b_dim1] = 0.;
 
	    }
 
	}
	return 0;
    }

 

    if (lside) {
	if (lsame_(transa, "N", 1L, 1L)) {

 

	    if (upper) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (k = 1; k <= i__2; ++k) {
			if (b[k + j * b_dim1] != 0.) {
			    temp = *alpha * b[k + j * b_dim1];
			    i__3 = k - 1;
			    for (i__ = 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] += temp * a[i__ + k * 
					a_dim1];
 
			    }
			    if (nounit) {
				temp *= a[k + k * a_dim1];
			    }
			    b[k + j * b_dim1] = temp;
			}
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    for (k = *m; k >= 1; --k) {
			if (b[k + j * b_dim1] != 0.) {
			    temp = *alpha * b[k + j * b_dim1];
			    b[k + j * b_dim1] = temp;
			    if (nounit) {
				b[k + j * b_dim1] *= a[k + k * a_dim1];
			    }
			    i__2 = *m;
			    for (i__ = k + 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] += temp * a[i__ + k * 
					a_dim1];
 
			    }
			}
 
		    }
 
		}
	    }
	} else {

 

	    if (upper) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    for (i__ = *m; i__ >= 1; --i__) {
			temp = b[i__ + j * b_dim1];
			if (nounit) {
			    temp *= a[i__ + i__ * a_dim1];
			}
			i__2 = i__ - 1;
			for (k = 1; k <= i__2; ++k) {
			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
 
			}
			b[i__ + j * b_dim1] = *alpha * temp;
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp = b[i__ + j * b_dim1];
			if (nounit) {
			    temp *= a[i__ + i__ * a_dim1];
			}
			i__3 = *m;
			for (k = i__ + 1; k <= i__3; ++k) {
			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
 
			}
			b[i__ + j * b_dim1] = *alpha * temp;
 
		    }
 
		}
	    }
	}
    } else {
	if (lsame_(transa, "N", 1L, 1L)) {

 

	    if (upper) {
		for (j = *n; j >= 1; --j) {
		    temp = *alpha;
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    i__1 = *m;
		    for (i__ = 1; i__ <= i__1; ++i__) {
			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
 
		    }
		    i__1 = j - 1;
		    for (k = 1; k <= i__1; ++k) {
			if (a[k + j * a_dim1] != 0.) {
			    temp = *alpha * a[k + j * a_dim1];
			    i__2 = *m;
			    for (i__ = 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] += temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = *alpha;
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
 
		    }
		    i__2 = *n;
		    for (k = j + 1; k <= i__2; ++k) {
			if (a[k + j * a_dim1] != 0.) {
			    temp = *alpha * a[k + j * a_dim1];
			    i__3 = *m;
			    for (i__ = 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] += temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
 
		}
	    }
	} else {

 

	    if (upper) {
		i__1 = *n;
		for (k = 1; k <= i__1; ++k) {
		    i__2 = k - 1;
		    for (j = 1; j <= i__2; ++j) {
			if (a[j + k * a_dim1] != 0.) {
			    temp = *alpha * a[j + k * a_dim1];
			    i__3 = *m;
			    for (i__ = 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] += temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
		    temp = *alpha;
		    if (nounit) {
			temp *= a[k + k * a_dim1];
		    }
		    if (temp != 1.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
 
			}
		    }
 
		}
	    } else {
		for (k = *n; k >= 1; --k) {
		    i__1 = *n;
		    for (j = k + 1; j <= i__1; ++j) {
			if (a[j + k * a_dim1] != 0.) {
			    temp = *alpha * a[j + k * a_dim1];
			    i__2 = *m;
			    for (i__ = 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] += temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
		    temp = *alpha;
		    if (nounit) {
			temp *= a[k + k * a_dim1];
		    }
		    if (temp != 1.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
 
			}
		    }
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dtrmv_(uplo, trans, diag, n, a, lda, x, incx, uplo_len, 
	trans_len, diag_len)
char *uplo, *trans, *diag;
integer *n;
doublereal *a;
integer *lda;
doublereal *x;
integer *incx;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j;
    extern logical lsame_();
    static integer ix, jx, kx;
    extern   int xerbla_();
    static logical nounit;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --x;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) &&
	     ! lsame_(trans, "C", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	info = 6;
    } else if (*incx == 0) {
	info = 8;
    }
    if (info != 0) {
	xerbla_("DTRMV ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    nounit = lsame_(diag, "N", 1L, 1L);

 
 

    if (*incx <= 0) {
	kx = 1 - (*n - 1) * *incx;
    } else if (*incx != 1) {
	kx = 1;
    }

 
 

    if (lsame_(trans, "N", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[j] != 0.) {
			temp = x[j];
			i__2 = j - 1;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    x[i__] += temp * a[i__ + j * a_dim1];
 
			}
			if (nounit) {
			    x[j] *= a[j + j * a_dim1];
			}
		    }
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[jx] != 0.) {
			temp = x[jx];
			ix = kx;
			i__2 = j - 1;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    x[ix] += temp * a[i__ + j * a_dim1];
			    ix += *incx;
 
			}
			if (nounit) {
			    x[jx] *= a[j + j * a_dim1];
			}
		    }
		    jx += *incx;
 
		}
	    }
	} else {
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    if (x[j] != 0.) {
			temp = x[j];
			i__1 = j + 1;
			for (i__ = *n; i__ >= i__1; --i__) {
			    x[i__] += temp * a[i__ + j * a_dim1];
 
			}
			if (nounit) {
			    x[j] *= a[j + j * a_dim1];
			}
		    }
 
		}
	    } else {
		kx += (*n - 1) * *incx;
		jx = kx;
		for (j = *n; j >= 1; --j) {
		    if (x[jx] != 0.) {
			temp = x[jx];
			ix = kx;
			i__1 = j + 1;
			for (i__ = *n; i__ >= i__1; --i__) {
			    x[ix] += temp * a[i__ + j * a_dim1];
			    ix -= *incx;
 
			}
			if (nounit) {
			    x[jx] *= a[j + j * a_dim1];
			}
		    }
		    jx -= *incx;
 
		}
	    }
	}
    } else {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    temp = x[j];
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    for (i__ = j - 1; i__ >= 1; --i__) {
			temp += a[i__ + j * a_dim1] * x[i__];
 
		    }
		    x[j] = temp;
 
		}
	    } else {
		jx = kx + (*n - 1) * *incx;
		for (j = *n; j >= 1; --j) {
		    temp = x[jx];
		    ix = jx;
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    for (i__ = j - 1; i__ >= 1; --i__) {
			ix -= *incx;
			temp += a[i__ + j * a_dim1] * x[ix];
 
		    }
		    x[jx] = temp;
		    jx -= *incx;
 
		}
	    }
	} else {
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[j];
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    i__2 = *n;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
			temp += a[i__ + j * a_dim1] * x[i__];
 
		    }
		    x[j] = temp;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[jx];
		    ix = jx;
		    if (nounit) {
			temp *= a[j + j * a_dim1];
		    }
		    i__2 = *n;
		    for (i__ = j + 1; i__ <= i__2; ++i__) {
			ix += *incx;
			temp += a[i__ + j * a_dim1] * x[ix];
 
		    }
		    x[jx] = temp;
		    jx += *incx;
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dtrsm_(side, uplo, transa, diag, m, n, alpha, a, lda, b, 
	ldb, side_len, uplo_len, transa_len, diag_len)
char *side, *uplo, *transa, *diag;
integer *m, *n;
doublereal *alpha, *a;
integer *lda;
doublereal *b;
integer *ldb;
ftnlen side_len;
ftnlen uplo_len;
ftnlen transa_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;

     
    static integer info;
    static doublereal temp;
    static integer i__, j, k;
    static logical lside;
    extern logical lsame_();
    static integer nrowa;
    static logical upper;
    extern   int xerbla_();
    static logical nounit;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = b_dim1 + 1;
    b -= b_offset;

     
    lside = lsame_(side, "L", 1L, 1L);
    if (lside) {
	nrowa = *m;
    } else {
	nrowa = *n;
    }
    nounit = lsame_(diag, "N", 1L, 1L);
    upper = lsame_(uplo, "U", 1L, 1L);

    info = 0;
    if (! lside && ! lsame_(side, "R", 1L, 1L)) {
	info = 1;
    } else if (! upper && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(transa, "N", 1L, 1L) && ! lsame_(transa, "T", 1L, 1L) 
	    && ! lsame_(transa, "C", 1L, 1L)) {
	info = 3;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 4;
    } else if (*m < 0) {
	info = 5;
    } else if (*n < 0) {
	info = 6;
    } else if (*lda < (( 1 ) >= ( nrowa ) ? ( 1 ) : ( nrowa )) ) {
	info = 9;
    } else if (*ldb < (( 1 ) >= ( *m ) ? ( 1 ) : ( *m )) ) {
	info = 11;
    }
    if (info != 0) {
	xerbla_("DTRSM ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

 

    if (*alpha == 0.) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		b[i__ + j * b_dim1] = 0.;
 
	    }
 
	}
	return 0;
    }

 

    if (lside) {
	if (lsame_(transa, "N", 1L, 1L)) {

 

	    if (upper) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (*alpha != 1.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
				    ;
 
			}
		    }
		    for (k = *m; k >= 1; --k) {
			if (b[k + j * b_dim1] != 0.) {
			    if (nounit) {
				b[k + j * b_dim1] /= a[k + k * a_dim1];
			    }
			    i__2 = k - 1;
			    for (i__ = 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
					i__ + k * a_dim1];
 
			    }
			}
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (*alpha != 1.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
				    ;
 
			}
		    }
		    i__2 = *m;
		    for (k = 1; k <= i__2; ++k) {
			if (b[k + j * b_dim1] != 0.) {
			    if (nounit) {
				b[k + j * b_dim1] /= a[k + k * a_dim1];
			    }
			    i__3 = *m;
			    for (i__ = k + 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
					i__ + k * a_dim1];
 
			    }
			}
 
		    }
 
		}
	    }
	} else {

 

	    if (upper) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp = *alpha * b[i__ + j * b_dim1];
			i__3 = i__ - 1;
			for (k = 1; k <= i__3; ++k) {
			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
 
			}
			if (nounit) {
			    temp /= a[i__ + i__ * a_dim1];
			}
			b[i__ + j * b_dim1] = temp;
 
		    }
 
		}
	    } else {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    for (i__ = *m; i__ >= 1; --i__) {
			temp = *alpha * b[i__ + j * b_dim1];
			i__2 = *m;
			for (k = i__ + 1; k <= i__2; ++k) {
			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
 
			}
			if (nounit) {
			    temp /= a[i__ + i__ * a_dim1];
			}
			b[i__ + j * b_dim1] = temp;
 
		    }
 
		}
	    }
	}
    } else {
	if (lsame_(transa, "N", 1L, 1L)) {

 

	    if (upper) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (*alpha != 1.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
				    ;
 
			}
		    }
		    i__2 = j - 1;
		    for (k = 1; k <= i__2; ++k) {
			if (a[k + j * a_dim1] != 0.) {
			    i__3 = *m;
			    for (i__ = 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
					i__ + k * b_dim1];
 
			    }
			}
 
		    }
		    if (nounit) {
			temp = 1. / a[j + j * a_dim1];
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
 
			}
		    }
 
		}
	    } else {
		for (j = *n; j >= 1; --j) {
		    if (*alpha != 1.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
				    ;
 
			}
		    }
		    i__1 = *n;
		    for (k = j + 1; k <= i__1; ++k) {
			if (a[k + j * a_dim1] != 0.) {
			    i__2 = *m;
			    for (i__ = 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
					i__ + k * b_dim1];
 
			    }
			}
 
		    }
		    if (nounit) {
			temp = 1. / a[j + j * a_dim1];
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
 
			}
		    }
 
		}
	    }
	} else {

 

	    if (upper) {
		for (k = *n; k >= 1; --k) {
		    if (nounit) {
			temp = 1. / a[k + k * a_dim1];
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
 
			}
		    }
		    i__1 = k - 1;
		    for (j = 1; j <= i__1; ++j) {
			if (a[j + k * a_dim1] != 0.) {
			    temp = a[j + k * a_dim1];
			    i__2 = *m;
			    for (i__ = 1; i__ <= i__2; ++i__) {
				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
		    if (*alpha != 1.) {
			i__1 = *m;
			for (i__ = 1; i__ <= i__1; ++i__) {
			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
				    ;
 
			}
		    }
 
		}
	    } else {
		i__1 = *n;
		for (k = 1; k <= i__1; ++k) {
		    if (nounit) {
			temp = 1. / a[k + k * a_dim1];
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
 
			}
		    }
		    i__2 = *n;
		    for (j = k + 1; j <= i__2; ++j) {
			if (a[j + k * a_dim1] != 0.) {
			    temp = a[j + k * a_dim1];
			    i__3 = *m;
			    for (i__ = 1; i__ <= i__3; ++i__) {
				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
					b_dim1];
 
			    }
			}
 
		    }
		    if (*alpha != 1.) {
			i__2 = *m;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
				    ;
 
			}
		    }
 
		}
	    }
	}
    }

    return 0;

 

}  

  int dtrsv_(uplo, trans, diag, n, a, lda, x, incx, uplo_len, 
	trans_len, diag_len)
char *uplo, *trans, *diag;
integer *n;
doublereal *a;
integer *lda;
doublereal *x;
integer *incx;
ftnlen uplo_len;
ftnlen trans_len;
ftnlen diag_len;
{
     
    integer a_dim1, a_offset, i__1, i__2;

     
    static integer info;
    static doublereal temp;
    static integer i__, j;
    extern logical lsame_();
    static integer ix, jx, kx;
    extern   int xerbla_();
    static logical nounit;
     
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --x;

     
    info = 0;
    if (! lsame_(uplo, "U", 1L, 1L) && ! lsame_(uplo, "L", 1L, 1L)) {
	info = 1;
    } else if (! lsame_(trans, "N", 1L, 1L) && ! lsame_(trans, "T", 1L, 1L) &&
	     ! lsame_(trans, "C", 1L, 1L)) {
	info = 2;
    } else if (! lsame_(diag, "U", 1L, 1L) && ! lsame_(diag, "N", 1L, 1L)) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*lda < (( 1 ) >= ( *n ) ? ( 1 ) : ( *n )) ) {
	info = 6;
    } else if (*incx == 0) {
	info = 8;
    }
    if (info != 0) {
	xerbla_("DTRSV ", &info, 6L);
	return 0;
    }

 

    if (*n == 0) {
	return 0;
    }

    nounit = lsame_(diag, "N", 1L, 1L);

 
 

    if (*incx <= 0) {
	kx = 1 - (*n - 1) * *incx;
    } else if (*incx != 1) {
	kx = 1;
    }

 
 

    if (lsame_(trans, "N", 1L, 1L)) {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    if (x[j] != 0.) {
			if (nounit) {
			    x[j] /= a[j + j * a_dim1];
			}
			temp = x[j];
			for (i__ = j - 1; i__ >= 1; --i__) {
			    x[i__] -= temp * a[i__ + j * a_dim1];
 
			}
		    }
 
		}
	    } else {
		jx = kx + (*n - 1) * *incx;
		for (j = *n; j >= 1; --j) {
		    if (x[jx] != 0.) {
			if (nounit) {
			    x[jx] /= a[j + j * a_dim1];
			}
			temp = x[jx];
			ix = jx;
			for (i__ = j - 1; i__ >= 1; --i__) {
			    ix -= *incx;
			    x[ix] -= temp * a[i__ + j * a_dim1];
 
			}
		    }
		    jx -= *incx;
 
		}
	    }
	} else {
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[j] != 0.) {
			if (nounit) {
			    x[j] /= a[j + j * a_dim1];
			}
			temp = x[j];
			i__2 = *n;
			for (i__ = j + 1; i__ <= i__2; ++i__) {
			    x[i__] -= temp * a[i__ + j * a_dim1];
 
			}
		    }
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    if (x[jx] != 0.) {
			if (nounit) {
			    x[jx] /= a[j + j * a_dim1];
			}
			temp = x[jx];
			ix = jx;
			i__2 = *n;
			for (i__ = j + 1; i__ <= i__2; ++i__) {
			    ix += *incx;
			    x[ix] -= temp * a[i__ + j * a_dim1];
 
			}
		    }
		    jx += *incx;
 
		}
	    }
	}
    } else {

 

	if (lsame_(uplo, "U", 1L, 1L)) {
	    if (*incx == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[j];
		    i__2 = j - 1;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp -= a[i__ + j * a_dim1] * x[i__];
 
		    }
		    if (nounit) {
			temp /= a[j + j * a_dim1];
		    }
		    x[j] = temp;
 
		}
	    } else {
		jx = kx;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    temp = x[jx];
		    ix = kx;
		    i__2 = j - 1;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp -= a[i__ + j * a_dim1] * x[ix];
			ix += *incx;
 
		    }
		    if (nounit) {
			temp /= a[j + j * a_dim1];
		    }
		    x[jx] = temp;
		    jx += *incx;
 
		}
	    }
	} else {
	    if (*incx == 1) {
		for (j = *n; j >= 1; --j) {
		    temp = x[j];
		    i__1 = j + 1;
		    for (i__ = *n; i__ >= i__1; --i__) {
			temp -= a[i__ + j * a_dim1] * x[i__];
 
		    }
		    if (nounit) {
			temp /= a[j + j * a_dim1];
		    }
		    x[j] = temp;
 
		}
	    } else {
		kx += (*n - 1) * *incx;
		jx = kx;
		for (j = *n; j >= 1; --j) {
		    temp = x[jx];
		    ix = kx;
		    i__1 = j + 1;
		    for (i__ = *n; i__ >= i__1; --i__) {
			temp -= a[i__ + j * a_dim1] * x[ix];
			ix -= *incx;
 
		    }
		    if (nounit) {
			temp /= a[j + j * a_dim1];
		    }
		    x[jx] = temp;
		    jx -= *incx;
 
		}
	    }
	}
    }

    return 0;

 

}  

integer ilaenv_(ispec, name__, opts, n1, n2, n3, n4, name_len, opts_len)
integer *ispec;
char *name__, *opts;
integer *n1, *n2, *n3, *n4;
ftnlen name_len;
ftnlen opts_len;
{
     
    integer ret_val;

     
      int s_copy();
    integer s_cmp();

     
    static integer i__;
    static logical cname, sname;
    static integer nbmin;
    static char c1[1], c2[2], c3[3], c4[2];
    static integer ic, nb, iz, nx;
    static char subnam[6];

    switch ((int)*ispec) {
	case 1:  goto L100;
	case 2:  goto L100;
	case 3:  goto L100;
	case 4:  goto L400;
	case 5:  goto L500;
	case 6:  goto L600;
	case 7:  goto L700;
	case 8:  goto L800;
    }

 

    ret_val = -1;
    return ret_val;

L100:

 

    ret_val = 1;
    s_copy(subnam, name__, 6L, name_len);
    ic = *(unsigned char *)subnam;
    iz = 'Z';
    if (iz == 90 || iz == 122) {

 

	if (ic >= 97 && ic <= 122) {
	    *(unsigned char *)subnam = (char) (ic - 32);
	    for (i__ = 2; i__ <= 6; ++i__) {
		ic = *(unsigned char *)&subnam[i__ - 1];
		if (ic >= 97 && ic <= 122) {
		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
		}
 
	    }
	}

    } else if (iz == 233 || iz == 169) {

 

	if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && 
		ic <= 169) {
	    *(unsigned char *)subnam = (char) (ic + 64);
	    for (i__ = 2; i__ <= 6; ++i__) {
		ic = *(unsigned char *)&subnam[i__ - 1];
		if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 
			162 && ic <= 169) {
		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
		}
 
	    }
	}

    } else if (iz == 218 || iz == 250) {

 

	if (ic >= 225 && ic <= 250) {
	    *(unsigned char *)subnam = (char) (ic - 32);
	    for (i__ = 2; i__ <= 6; ++i__) {
		ic = *(unsigned char *)&subnam[i__ - 1];
		if (ic >= 225 && ic <= 250) {
		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
		}
 
	    }
	}
    }

    *(unsigned char *)c1 = *(unsigned char *)subnam;
    sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
    cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
    if (! (cname || sname)) {
	return ret_val;
    }
    s_copy(c2, subnam + 1, 2L, 2L);
    s_copy(c3, subnam + 3, 3L, 3L);
    s_copy(c4, c3 + 1, 2L, 2L);

    switch ((int)*ispec) {
	case 1:  goto L110;
	case 2:  goto L200;
	case 3:  goto L300;
    }

L110:

 

 
 
 

    nb = 1;

    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	} else if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) 
		== 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 
		3L) == 0) {
	    if (sname) {
		nb = 32;
	    } else {
		nb = 32;
	    }
	} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
	    if (sname) {
		nb = 32;
	    } else {
		nb = 32;
	    }
	} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
	    if (sname) {
		nb = 32;
	    } else {
		nb = 32;
	    }
	} else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	}
    } else if (s_cmp(c2, "PO", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	}
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	} else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nb = 1;
	} else if (sname && s_cmp(c3, "GST", 3L, 3L) == 0) {
	    nb = 64;
	}
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    nb = 64;
	} else if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nb = 1;
	} else if (s_cmp(c3, "GST", 3L, 3L) == 0) {
	    nb = 64;
	}
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nb = 32;
	    }
	} else if (*(unsigned char *)c3 == 'M') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nb = 32;
	    }
	}
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nb = 32;
	    }
	} else if (*(unsigned char *)c3 == 'M') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nb = 32;
	    }
	}
    } else if (s_cmp(c2, "GB", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		if (*n4 <= 64) {
		    nb = 1;
		} else {
		    nb = 32;
		}
	    } else {
		if (*n4 <= 64) {
		    nb = 1;
		} else {
		    nb = 32;
		}
	    }
	}
    } else if (s_cmp(c2, "PB", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		if (*n2 <= 64) {
		    nb = 1;
		} else {
		    nb = 32;
		}
	    } else {
		if (*n2 <= 64) {
		    nb = 1;
		} else {
		    nb = 32;
		}
	    }
	}
    } else if (s_cmp(c2, "TR", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	}
    } else if (s_cmp(c2, "LA", 2L, 2L) == 0) {
	if (s_cmp(c3, "UUM", 3L, 3L) == 0) {
	    if (sname) {
		nb = 64;
	    } else {
		nb = 64;
	    }
	}
    } else if (sname && s_cmp(c2, "ST", 2L, 2L) == 0) {
	if (s_cmp(c3, "EBZ", 3L, 3L) == 0) {
	    nb = 1;
	}
    }
    ret_val = nb;
    return ret_val;

L200:

 

    nbmin = 2;
    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
	if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || 
		s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 
		0) {
	    if (sname) {
		nbmin = 2;
	    } else {
		nbmin = 2;
	    }
	} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
	    if (sname) {
		nbmin = 2;
	    } else {
		nbmin = 2;
	    }
	} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
	    if (sname) {
		nbmin = 2;
	    } else {
		nbmin = 2;
	    }
	} else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
	    if (sname) {
		nbmin = 2;
	    } else {
		nbmin = 2;
	    }
	}
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
	    if (sname) {
		nbmin = 8;
	    } else {
		nbmin = 8;
	    }
	} else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nbmin = 2;
	}
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nbmin = 2;
	}
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nbmin = 2;
	    }
	} else if (*(unsigned char *)c3 == 'M') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nbmin = 2;
	    }
	}
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nbmin = 2;
	    }
	} else if (*(unsigned char *)c3 == 'M') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nbmin = 2;
	    }
	}
    }
    ret_val = nbmin;
    return ret_val;

L300:

 

    nx = 0;
    if (s_cmp(c2, "GE", 2L, 2L) == 0) {
	if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 || 
		s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) == 
		0) {
	    if (sname) {
		nx = 128;
	    } else {
		nx = 128;
	    }
	} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
	    if (sname) {
		nx = 128;
	    } else {
		nx = 128;
	    }
	} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
	    if (sname) {
		nx = 128;
	    } else {
		nx = 128;
	    }
	}
    } else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
	if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nx = 1;
	}
    } else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
	if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
	    nx = 1;
	}
    } else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nx = 128;
	    }
	}
    } else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
	if (*(unsigned char *)c3 == 'G') {
	    if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0 
		    || s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
		     == 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR", 
		    2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
		nx = 128;
	    }
	}
    }
    ret_val = nx;
    return ret_val;

L400:

 

    ret_val = 6;
    return ret_val;

L500:

 

    ret_val = 2;
    return ret_val;

L600:

 

    ret_val = (integer) ((real) (( *n1 ) <= ( *n2 ) ? ( *n1 ) : ( *n2 ))  * (float)1.6);
    return ret_val;

L700:

 

    ret_val = 1;
    return ret_val;

L800:

 

    ret_val = 50;
    return ret_val;

 

}  

logical lsame_(ca, cb, ca_len, cb_len)
char *ca, *cb;
ftnlen ca_len;
ftnlen cb_len;
{
     
    logical ret_val;

     
    static integer inta, intb, zcode;
    ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
    if (ret_val) {
	return ret_val;
    }

    zcode = 'Z';
    inta = *(unsigned char *)ca;
    intb = *(unsigned char *)cb;

    if (zcode == 90 || zcode == 122) {

 

 

	if (inta >= 97 && inta <= 122) {
	    inta += -32;
	}
	if (intb >= 97 && intb <= 122) {
	    intb += -32;
	}

    } else if (zcode == 233 || zcode == 169) {

 

 

	if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta 
		>= 162 && inta <= 169) {
	    inta += 64;
	}
	if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb 
		>= 162 && intb <= 169) {
	    intb += 64;
	}

    } else if (zcode == 218 || zcode == 250) {

 

 

	if (inta >= 225 && inta <= 250) {
	    inta += -32;
	}
	if (intb >= 225 && intb <= 250) {
	    intb += -32;
	}
    }
    ret_val = inta == intb;

 

 

    return ret_val;
}  

  int xerbla_(srname, info, srname_len)
char *srname;
integer *info;
ftnlen srname_len;
{
     
    static char fmt_9999[] = "(\002 ** On entry to \002,a6,\002 parameter number \002,i2,\002 had \002,\002an illegal value\002)";

     
    integer s_wsfe(), do_fio(), e_wsfe();
      int s_stop();

     
    static cilist io___630 = { 0, 6, 0, fmt_9999, 0 };
    s_wsfe(&io___630);
    do_fio(&c__1, srname, 6L);
    do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
    e_wsfe();

    s_stop("", 0L);
}  

 
  int ainvg_(res, adda, neq, t, y, ydot, miter, ml, mu, pw, 
	ipvt, ier)
  int (*res) (), (*adda) ();
integer *neq;
doublereal *t, *y, *ydot;
integer *miter, *ml, *mu;
doublereal *pw;
integer *ipvt, *ier;
{
     
    integer i__1;

     
    extern   int dgbfa_(), dgefa_();
    static integer i__;
    extern   int dgbsl_(), dgesl_();
    static integer lenpw, nrowpw, mlp1;

 
 

 
 
 
 
 
 
 
 
 
 
 
 


     
    --ipvt;
    --pw;
    --ydot;
    --y;

     
    if (*miter >= 4) {
	goto L100;
    }

 


    lenpw = *neq * *neq;
    i__1 = lenpw;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	pw[i__] = 0.;
    }

    *ier = 1;
    (*res)(neq, t, &y[1], &pw[1], &ydot[1], ier);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if (*ier > 1) {
	return 0;
    }

    (*adda)(neq, t, &y[1], &c__0, &c__0, &pw[1], neq);
    if (ierode_ .iero > 0) {
	return 0;
    }
    dgefa_(&pw[1], neq, neq, &ipvt[1], ier);
    if (*ier == 0) {
	goto L20;
    }
    *ier = -(*ier);
    return 0;
L20:
    dgesl_(&pw[1], neq, neq, &ipvt[1], &ydot[1], &c__0);
    return 0;

 


L100:
    nrowpw = (*ml << 1) + *mu + 1;
    lenpw = *neq * nrowpw;
    i__1 = lenpw;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	pw[i__] = 0.;
    }

    *ier = 1;
    (*res)(neq, t, &y[1], &pw[1], &ydot[1], ier);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if (*ier > 1) {
	return 0;
    }

    mlp1 = *ml + 1;
    (*adda)(neq, t, &y[1], ml, mu, &pw[mlp1], &nrowpw);
    if (ierode_ .iero > 0) {
	return 0;
    }
    dgbfa_(&pw[1], &nrowpw, neq, ml, mu, &ipvt[1], ier);
    if (*ier == 0) {
	goto L120;
    }
    *ier = -(*ier);
    return 0;
L120:
    dgbsl_(&pw[1], &nrowpw, neq, ml, mu, &ipvt[1], &ydot[1], &c__0);
    return 0;
 

}  

 
doublereal bnorm_(n, a, nra, ml, mu, w)
integer *n;
doublereal *a;
integer *nra, *ml, *mu;
doublereal *w;
{
     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal ret_val, d__1, d__2;

     
    static integer i__, j, i1;
    static doublereal an;
    static integer jhi, jlo;
    static doublereal sum;
    --w;
    a_dim1 = *nra;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    an = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sum = 0.;
	i1 = i__ + *mu + 1;
 
	i__2 = i__ - *ml;
	jlo = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ;
 
	i__2 = i__ + *mu;
	jhi = (( i__2 ) <= ( *n ) ? ( i__2 ) : ( *n )) ;
	i__2 = jhi;
	for (j = jlo; j <= i__2; ++j) {
 
	    sum += (d__1 = a[i1 - j + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / w[j];
	}
 
	d__1 = an, d__2 = sum * w[i__];
	an = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    }
    ret_val = an;
    return ret_val;
 

}  

 
  int cfode_(meth, elco, tesco)
integer *meth;
doublereal *elco, *tesco;
{
     
    integer i__1;

     
    static doublereal ragq, pint, xpin, fnqm1;
    static integer i__;
    static doublereal agamq, rqfac, tsign, rq1fac;
    static integer ib;
    static doublereal pc[12];
    static integer nq;
    static doublereal fnq;
    static integer nqm1, nqp1;
     
    tesco -= 4;
    elco -= 14;

     
    switch ((int)*meth) {
	case 1:  goto L100;
	case 2:  goto L200;
    }

L100:
    elco[14] = 1.;
    elco[15] = 1.;
    tesco[4] = 0.;
    tesco[5] = 2.;
    tesco[7] = 1.;
    tesco[39] = 0.;
    pc[0] = 1.;
    rqfac = 1.;
    for (nq = 2; nq <= 12; ++nq) {
 

 
 
 
 

	rq1fac = rqfac;
	rqfac /= (doublereal) nq;
	nqm1 = nq - 1;
	fnqm1 = (doublereal) nqm1;
	nqp1 = nq + 1;
 

	pc[nq - 1] = 0.;
	i__1 = nqm1;
	for (ib = 1; ib <= i__1; ++ib) {
	    i__ = nqp1 - ib;
 
	    pc[i__ - 1] = pc[i__ - 2] + fnqm1 * pc[i__ - 1];
	}
	pc[0] = fnqm1 * pc[0];
 

	pint = pc[0];
	xpin = pc[0] / 2.;
	tsign = 1.;
	i__1 = nq;
	for (i__ = 2; i__ <= i__1; ++i__) {
	    tsign = -tsign;
	    pint += tsign * pc[i__ - 1] / (doublereal) i__;
 
	    xpin += tsign * pc[i__ - 1] / (doublereal) (i__ + 1);
	}
 

	elco[nq * 13 + 1] = pint * rq1fac;
	elco[nq * 13 + 2] = 1.;
	i__1 = nq;
	for (i__ = 2; i__ <= i__1; ++i__) {
 
	    elco[i__ + 1 + nq * 13] = rq1fac * pc[i__ - 1] / (doublereal) i__;
	}
	agamq = rqfac * xpin;
	ragq = 1. / agamq;
	tesco[nq * 3 + 2] = ragq;
	if (nq < 12) {
	    tesco[nqp1 * 3 + 1] = ragq * rqfac / (doublereal) nqp1;
	}
	tesco[nqm1 * 3 + 3] = ragq;
 
    }
    return 0;

L200:
    pc[0] = 1.;
    rq1fac = 1.;
    for (nq = 1; nq <= 5; ++nq) {
 

 
 
 
 

	fnq = (doublereal) nq;
	nqp1 = nq + 1;
 

	pc[nqp1 - 1] = 0.;
	i__1 = nq;
	for (ib = 1; ib <= i__1; ++ib) {
	    i__ = nq + 2 - ib;
 
	    pc[i__ - 1] = pc[i__ - 2] + fnq * pc[i__ - 1];
	}
	pc[0] = fnq * pc[0];
 

	i__1 = nqp1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    elco[i__ + nq * 13] = pc[i__ - 1] / pc[1];
	}
	elco[nq * 13 + 2] = 1.;
	tesco[nq * 3 + 1] = rq1fac;
	tesco[nq * 3 + 2] = (doublereal) nqp1 / elco[nq * 13 + 1];
	tesco[nq * 3 + 3] = (doublereal) (nq + 2) / elco[nq * 13 + 1];
	rq1fac /= fnq;
 
    }
    return 0;
 

}  
 

  int colnew_0_(n__, ncomp, m, aleft, aright, zeta, ipar, ltol,
	 tol, fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess)
int n__;
integer *ncomp, *m;
doublereal *aleft, *aright, *zeta;
integer *ipar, *ltol;
doublereal *tol, *fixpnt;
integer *ispace;
doublereal *fspace;
integer *iflag;
  int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (*
	guess) ();
{
     
    static char fmt_99[] = "(//,\002 VERSION *COLNEW* OF COLSYS .    \002,//)"
	    ;
    static char fmt_260[] = "(///\002 THE NUMBER OF (LINEAR) DIFF EQNS IS \002,i3/1x,\002THEIR ORDERS ARE\002,20i3)";
    static char fmt_270[] = "(///\002 THE NUMBER OF (NONLINEAR) DIFF EQNS IS \002,i3/1x,\002THEIR ORDERS ARE\002,20i3)";
    static char fmt_280[] = "(\002 SIDE CONDITION POINTS ZETA\002,8f10.6,4(/27x,8f10.6))";
    static char fmt_340[] = "(\002 THERE ARE\002,i5,\002 FIXED POINTS IN THE MESH -\002,10(6f10.6/))";
    static char fmt_290[] = "(\002 NUMBER OF COLLOC PTS PER INTERVAL IS\002,i3)";
    static char fmt_300[] = "(\002 COMPONENTS OF Z REQUIRING TOLERANCES -\002,8(7x,i2,1x),4(/38x,8i10))";
    static char fmt_310[] = "(\002 CORRESPONDING ERROR TOLERANCES -\002,6x,8d10.2,4(/39x,8d10.2))";
    static char fmt_320[] = "(\002 INITIAL MESH(ES) AND Z,DMZ PROVIDED BY USER\002)";
    static char fmt_330[] = "(\002 NO ADAPTIVE MESH SELECTION\002)";
    static char fmt_350[] = "(\002 THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (\002,i4,\002 (ALLOWED FROM FSPACE),\002,i4,\002 (ALLOWED FROM ISPACE) )\002)";
    static char fmt_360[] = "(/\002 INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE\002)";

     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2;

     
    integer s_wsfe(), e_wsfe(), do_fio();

     
    static integer nrec, lscl, ldmz, idmz, ldqz, lrhs, i__, iread, ndimf, 
	    ndimi, ldscl, nmaxf, nfixf, ldelz, nfixi, nmaxi;
    static doublereal dummy[1];
    static integer lpvtg, k2, lpvtw;
    static doublereal precp1;
    static integer ib, ic, lg, ip, lw, lv, lz, laccum, ldeldz, linteg, lxiold,
	     ldqdmz, nsizef, lslope, nsizei;
    extern   int newmsh_();
    static integer lvalst;
    extern   int consts_();
    static integer nfxpnt;
    extern   int contrl_();
    static integer np1, lxi;

     
    static cilist io___657 = { 0, 6, 0, fmt_99, 0 };
    static cilist io___664 = { 0, 0, 0, fmt_260, 0 };
    static cilist io___666 = { 0, 0, 0, fmt_270, 0 };
    static cilist io___667 = { 0, 0, 0, fmt_280, 0 };
    static cilist io___668 = { 0, 0, 0, fmt_340, 0 };
    static cilist io___669 = { 0, 0, 0, fmt_290, 0 };
    static cilist io___670 = { 0, 0, 0, fmt_300, 0 };
    static cilist io___671 = { 0, 0, 0, fmt_310, 0 };
    static cilist io___672 = { 0, 0, 0, fmt_320, 0 };
    static cilist io___673 = { 0, 0, 0, fmt_330, 0 };
    static cilist io___682 = { 0, 0, 0, fmt_350, 0 };
    static cilist io___683 = { 0, 0, 0, fmt_360, 0 };
    --m;
    --zeta;
    --ipar;
    --ltol;
    --tol;
    --fixpnt;
    --ispace;
    --fspace;

     
    switch(n__) {
	case 1: goto L_colsys;
	}


L_colsys:
    if (ipar[7] <= 0) {
	s_wsfe(&io___657);
	e_wsfe();
    }

    colout_ .iout = 6;
    colout_ .precis = 1.;
L10:
    colout_ .precis /= 2.;
    precp1 = colout_ .precis + 1.;
    if (precp1 > 1.) {
	goto L10;
    }
    colout_ .precis *= 100.;

 
 

    *iflag = -3;
    if (*ncomp < 1 || *ncomp > 20) {
	return 0;
    }
    i__1 = *ncomp;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (m[i__] < 1 || m[i__] > 4) {
	    return 0;
	}
 
    }

 

    colnln_ .nonlin = ipar[1];
    (colord_._1) .k = ipar[2];
    colapr_ .n = ipar[3];
    if (colapr_ .n == 0) {
	colapr_ .n = 5;
    }
    iread = ipar[8];
    colnln_ .iguess = ipar[9];
    if (colnln_ .nonlin == 0 && colnln_ .iguess == 1) {
	colnln_ .iguess = 0;
    }
    if (colnln_ .iguess >= 2 && iread == 0) {
	iread = 1;
    }
    colnln_ .icare = ipar[10];
    (colest_._1) .ntol = ipar[4];
    ndimf = ipar[5];
    ndimi = ipar[6];
    nfxpnt = ipar[11];
    colout_ .iprint = ipar[7];
    (colord_._1) .mstar = 0;
    (colord_._1) .mmax = 0;
    i__1 = *ncomp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	i__2 = (colord_._1) .mmax, i__3 = m[i__];
	(colord_._1) .mmax = (( i__2 ) >= ( i__3 ) ? ( i__2 ) : ( i__3 )) ;
	(colord_._1) .mstar += m[i__];
	(colord_._1) .mt[i__ - 1] = m[i__];
 
    }
    if ((colord_._1) .k == 0) {
 
	i__1 = (colord_._1) .mmax + 1, i__2 = 5 - (colord_._1) .mmax;
	(colord_._1) .k = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    }
    i__1 = (colord_._1) .mstar;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(colsid_._1) .tzeta[i__ - 1] = zeta[i__];
    }
    i__1 = (colest_._1) .ntol;
    for (i__ = 1; i__ <= i__1; ++i__) {
	(colest_._1) .lttol[i__ - 1] = ltol[i__];
 
	(colest_._1) .tolin[i__ - 1] = tol[i__];
    }
    (colsid_._1) .tleft = *aleft;
    (colsid_._1) .tright = *aright;
    (colord_._1) .nc = *ncomp;
    (colord_._1) .kd = (colord_._1) .k * *ncomp;

 

    if (colout_ .iprint > -1) {
	goto L80;
    }
    if (colnln_ .nonlin > 0) {
	goto L60;
    }
    io___664.ciunit = colout_ .iout;
    s_wsfe(&io___664);
    do_fio(&c__1, (char *)&(*ncomp), (ftnlen)sizeof(integer));
    i__1 = *ncomp;
    for (ip = 1; ip <= i__1; ++ip) {
	do_fio(&c__1, (char *)&m[ip], (ftnlen)sizeof(integer));
    }
    e_wsfe();
    goto L70;
L60:
    io___666.ciunit = colout_ .iout;
    s_wsfe(&io___666);
    do_fio(&c__1, (char *)&(*ncomp), (ftnlen)sizeof(integer));
    i__1 = *ncomp;
    for (ip = 1; ip <= i__1; ++ip) {
	do_fio(&c__1, (char *)&m[ip], (ftnlen)sizeof(integer));
    }
    e_wsfe();
L70:
    io___667.ciunit = colout_ .iout;
    s_wsfe(&io___667);
    i__1 = (colord_._1) .mstar;
    for (ip = 1; ip <= i__1; ++ip) {
	do_fio(&c__1, (char *)&zeta[ip], (ftnlen)sizeof(doublereal));
    }
    e_wsfe();
    if (nfxpnt > 0) {
	io___668.ciunit = colout_ .iout;
	s_wsfe(&io___668);
	do_fio(&c__1, (char *)&nfxpnt, (ftnlen)sizeof(integer));
	i__1 = nfxpnt;
	for (ip = 1; ip <= i__1; ++ip) {
	    do_fio(&c__1, (char *)&fixpnt[ip], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }
    io___669.ciunit = colout_ .iout;
    s_wsfe(&io___669);
    do_fio(&c__1, (char *)& (colord_._1) .k, (ftnlen)sizeof(integer));
    e_wsfe();
    io___670.ciunit = colout_ .iout;
    s_wsfe(&io___670);
    i__1 = (colest_._1) .ntol;
    for (ip = 1; ip <= i__1; ++ip) {
	do_fio(&c__1, (char *)&ltol[ip], (ftnlen)sizeof(integer));
    }
    e_wsfe();
    io___671.ciunit = colout_ .iout;
    s_wsfe(&io___671);
    i__1 = (colest_._1) .ntol;
    for (ip = 1; ip <= i__1; ++ip) {
	do_fio(&c__1, (char *)&tol[ip], (ftnlen)sizeof(doublereal));
    }
    e_wsfe();
    if (colnln_ .iguess >= 2) {
	io___672.ciunit = colout_ .iout;
	s_wsfe(&io___672);
	e_wsfe();
    }
    if (iread == 2) {
	io___673.ciunit = colout_ .iout;
	s_wsfe(&io___673);
	e_wsfe();
    }
L80:

 

    if ((colord_._1) .k < 0 || (colord_._1) .k > 7) {
	return 0;
    }
    if (colapr_ .n < 0) {
	return 0;
    }
    if (iread < 0 || iread > 2) {
	return 0;
    }
    if (colnln_ .iguess < 0 || colnln_ .iguess > 4) {
	return 0;
    }
    if (colnln_ .icare < 0 || colnln_ .icare > 2) {
	return 0;
    }
    if ((colest_._1) .ntol < 0 || (colest_._1) .ntol > (colord_._1) .mstar) {
	return 0;
    }
    if (nfxpnt < 0) {
	return 0;
    }
    if (colout_ .iprint < -1 || colout_ .iprint > 1) {
	return 0;
    }
    if ((colord_._1) .mstar < 0 || (colord_._1) .mstar > 40) {
	return 0;
    }
    ip = 1;
    i__1 = (colord_._1) .mstar;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = zeta[i__] - *aleft, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < colout_ .precis || (d__2 
		= zeta[i__] - *aright, (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) < colout_ .precis) {
	    goto L100;
	}
L90:
	if (ip > nfxpnt) {
	    return 0;
	}
	if (zeta[i__] - colout_ .precis < fixpnt[ip]) {
	    goto L95;
	}
	++ip;
	goto L90;
L95:
	if (zeta[i__] + colout_ .precis < fixpnt[ip]) {
	    return 0;
	}
L100:
	;
    }

 
 
 
 

    colmsh_ .mshlmt = 3;
    colmsh_ .mshflg = 0;
    colmsh_ .mshnum = 1;
    colmsh_ .mshalt = 1;
    colnln_ .limit = 40;

 
 

    nrec = 0;
    i__1 = (colord_._1) .mstar;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ib = (colord_._1) .mstar + 1 - i__;
	if (zeta[ib] >= *aright) {
	    nrec = i__;
	}
 
    }
    nfixi = (colord_._1) .mstar;
    nsizei = (colord_._1) .kd + 3 + (colord_._1) .mstar;
    nfixf = nrec * ((colord_._1) .mstar << 1) + (colord_._1) .mstar * 5 + 3;
    nsizef = (colord_._1) .mstar * 3 + 4 + ((colord_._1) .kd + 5) * ((colord_._1) .kd + 
	    (colord_._1) .mstar) + (((colord_._1) .mstar << 1) - nrec << 1) * 
	    (colord_._1) .mstar;
    nmaxf = (ndimf - nfixf) / nsizef;
    nmaxi = (ndimi - nfixi) / nsizei;
    if (colout_ .iprint < 1) {
	io___682.ciunit = colout_ .iout;
	s_wsfe(&io___682);
	do_fio(&c__1, (char *)&nmaxf, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nmaxi, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    colapr_ .nmax = (( nmaxf ) <= ( nmaxi ) ? ( nmaxf ) : ( nmaxi )) ;
    if (colapr_ .nmax < colapr_ .n) {
	return 0;
    }
    if (colapr_ .nmax < nfxpnt + 1) {
	return 0;
    }
    if (colapr_ .nmax < (nfxpnt << 1) + 2 && colout_ .iprint < 1) {
	io___683.ciunit = colout_ .iout;
	s_wsfe(&io___683);
	e_wsfe();
    }

 

    lxi = 1;
    lg = lxi + colapr_ .nmax + 1;
    lxiold = lg + ((colord_._1) .mstar << 1) * (colapr_ .nmax * (((colord_._1) .mstar <<
	     1) - nrec) + nrec);
    lw = lxiold + colapr_ .nmax + 1;
 
    i__1 = (colord_._1) .kd;
    lv = lw + i__1 * i__1 * colapr_ .nmax;
    lz = lv + (colord_._1) .mstar * (colord_._1) .kd * colapr_ .nmax;
    ldmz = lz + (colord_._1) .mstar * (colapr_ .nmax + 1);
    ldelz = ldmz + (colord_._1) .kd * colapr_ .nmax;
    ldeldz = ldelz + (colord_._1) .mstar * (colapr_ .nmax + 1);
    ldqz = ldeldz + (colord_._1) .kd * colapr_ .nmax;
    ldqdmz = ldqz + (colord_._1) .mstar * (colapr_ .nmax + 1);
    lrhs = ldqdmz + (colord_._1) .kd * colapr_ .nmax;
    lvalst = lrhs + (colord_._1) .kd * colapr_ .nmax + (colord_._1) .mstar;
    lslope = lvalst + ((colord_._1) .mstar << 2) * colapr_ .nmax;
    laccum = lslope + colapr_ .nmax;
    lscl = laccum + colapr_ .nmax + 1;
    ldscl = lscl + (colord_._1) .mstar * (colapr_ .nmax + 1);
    lpvtg = 1;
    lpvtw = lpvtg + (colord_._1) .mstar * (colapr_ .nmax + 1);
    linteg = lpvtw + (colord_._1) .kd * colapr_ .nmax;

 
 

    if (colnln_ .iguess < 2) {
	goto L160;
    }
    colapr_ .nold = colapr_ .n;
    if (colnln_ .iguess == 4) {
	colapr_ .nold = ispace[1];
    }
    colapr_ .nz = (colord_._1) .mstar * (colapr_ .nold + 1);
    colapr_ .ndmz = (colord_._1) .kd * colapr_ .nold;
    np1 = colapr_ .n + 1;
    if (colnln_ .iguess == 4) {
	np1 = np1 + colapr_ .nold + 1;
    }
    i__1 = colapr_ .nz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[lz + i__ - 1] = fspace[np1 + i__];
    }
    idmz = np1 + colapr_ .nz;
    i__1 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[ldmz + i__ - 1] = fspace[idmz + i__];
    }
    np1 = colapr_ .nold + 1;
    if (colnln_ .iguess == 4) {
	goto L140;
    }
    i__1 = np1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[lxiold + i__ - 1] = fspace[lxi + i__ - 1];
    }
    goto L160;
L140:
    i__1 = np1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[lxiold + i__ - 1] = fspace[colapr_ .n + 1 + i__];
    }
L160:

 

    consts_(& (colord_._1) .k, colloc_ .rho, colloc_ .coef);
    i__1 = iread + 3;
    newmsh_(&i__1, &fspace[lxi], &fspace[lxiold], dummy, dummy, dummy, dummy, 
	    dummy, &nfxpnt, &fixpnt[1]);

 

    if (colnln_ .iguess >= 2) {
	goto L230;
    }
    np1 = colapr_ .n + 1;
    i__1 = np1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[i__ + lxiold - 1] = fspace[i__ + lxi - 1];
    }
    colapr_ .nold = colapr_ .n;
    if (colnln_ .nonlin == 0 || colnln_ .iguess == 1) {
	goto L230;
    }

 
 

    i__1 = colapr_ .nz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[lz - 1 + i__] = 0.;
    }
    i__1 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[ldmz - 1 + i__] = 0.;
    }
L230:
    if (colnln_ .iguess >= 2) {
	colnln_ .iguess = 0;
    }
    contrl_(&fspace[lxi], &fspace[lxiold], &fspace[lz], &fspace[ldmz], &
	    fspace[lrhs], &fspace[ldelz], &fspace[ldeldz], &fspace[ldqz], &
	    fspace[ldqdmz], &fspace[lg], &fspace[lw], &fspace[lv], &fspace[
	    lvalst], &fspace[lslope], &fspace[lscl], &fspace[ldscl], &fspace[
	    laccum], &ispace[lpvtg], &ispace[linteg], &ispace[lpvtw], &nfxpnt,
	     &fixpnt[1], iflag, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    ispace[1] = colapr_ .n;
    ispace[2] = (colord_._1) .k;
    ispace[3] = *ncomp;
    ispace[4] = (colord_._1) .mstar;
    ispace[5] = (colord_._1) .mmax;
    ispace[6] = colapr_ .nz + colapr_ .ndmz + colapr_ .n + 2;
    k2 = (colord_._1) .k * (colord_._1) .k;
    ispace[7] = ispace[6] + k2 - 1;
    i__1 = *ncomp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	ispace[i__ + 7] = m[i__];
    }
    i__1 = colapr_ .nz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[colapr_ .n + 1 + i__] = fspace[lz - 1 + i__];
    }
    idmz = colapr_ .n + 1 + colapr_ .nz;
    i__1 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[idmz + i__] = fspace[ldmz - 1 + i__];
    }
    ic = idmz + colapr_ .ndmz;
    i__1 = k2;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	fspace[ic + i__] = colloc_ .coef[i__ - 1];
    }
    return 0;
 

}  

  int colnew_(ncomp, m, aleft, aright, zeta, ipar, ltol, tol, 
	fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess)
integer *ncomp, *m;
doublereal *aleft, *aright, *zeta;
integer *ipar, *ltol;
doublereal *tol, *fixpnt;
integer *ispace;
doublereal *fspace;
integer *iflag;
  int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (*
	guess) ();
{
    return colnew_0_(0, ncomp, m, aleft, aright, zeta, ipar, ltol, tol, 
	    fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess);
    }

  int colsys_(ncomp, m, aleft, aright, zeta, ipar, ltol, tol, 
	fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess)
integer *ncomp, *m;
doublereal *aleft, *aright, *zeta;
integer *ipar, *ltol;
doublereal *tol, *fixpnt;
integer *ispace;
doublereal *fspace;
integer *iflag;
  int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (*
	guess) ();
{
    return colnew_0_(1, ncomp, m, aleft, aright, zeta, ipar, ltol, tol, 
	    fixpnt, ispace, fspace, iflag, fsub, dfsub, gsub, dgsub, guess);
    }

  int contrl_(xi, xiold, z__, dmz, rhs, delz, deldmz, dqz, 
	dqdmz, g, w, v, valstr, slope, scale, dscale, accum, ipvtg, integs, 
	ipvtw, nfxpnt, fixpnt, iflag, fsub, dfsub, gsub, dgsub, guess)
doublereal *xi, *xiold, *z__, *dmz, *rhs, *delz, *deldmz, *dqz, *dqdmz, *g, *
	w, *v, *valstr, *slope, *scale, *dscale, *accum;
integer *ipvtg, *integs, *ipvtw, *nfxpnt;
doublereal *fixpnt;
integer *iflag;
  int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (*
	guess) ();
{
     
    static char fmt_495[] = "(//\002 A LOCAL ELIMINATION MATRIX IS SINGULAR \002)";
    static char fmt_490[] = "(//\002 THE GLOBAL BVP-MATRIX IS SINGULAR \002)";
    static char fmt_530[] = "(/\002 FIXED JACOBIAN ITERATIONS,\002)";
    static char fmt_510[] = "(\002 ITERATION = \002,i3,\002  NORM (RHS) = \002,d10.2)";
    static char fmt_560[] = "(/\002 CONVERGENCE AFTER\002,i3,\002 ITERATIONS\002/)";
    static char fmt_540[] = "(/\002 SWITCH TO DAMPED NEWTON ITERATION,\002)";
    static char fmt_500[] = "(/\002 FULL DAMPED NEWTON ITERATION,\002)";
    static char fmt_520[] = "(\002 ITERATION = \002,i3,\002  RELAXATION FACTOR = \002,d10.2/\002 NORM OF SCALED RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2/\002 NORM   OF   RHS  CHANGES  FROM  \002,d10.2,\002 TO\002,d10.2,d10.2)";
    static char fmt_550[] = "(\002 RELAXATION FACTOR CORRECTED TO RELAX = \002,d10.2/\002 NORM OF SCALED RHS CHANGES FROM \002,d10.2,\002 TO\002,d10.2/\002 NORM   OF   RHS  CHANGES  FROM  \002,d10.2,\002 TO\002,d10.2,d10.2)";
    static char fmt_610[] = "(\002 MESH VALUES FOR Z(\002,i2,\002),\002)";
    static char fmt_620[] = "(\002 \002,8d15.7)";
    static char fmt_570[] = "(/\002 NO CONVERGENCE AFTER \002,i3,\002 ITERATIONS\002/)";
    static char fmt_580[] = "(/\002 NO CONVERGENCE.  RELAXATION FACTOR =\002,d10.3,\002 IS TOO SMALL (LESS THAN\002,d10.3,\002)\002/)";
    static char fmt_590[] = "(\002  (NO CONVERGENCE)\002)";
    static char fmt_600[] = "(\002  (PROBABLY TOLERANCES TOO STRINGENT, OR NMAX TOO \002,\002SMALL)\002)";

     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2;

     
    integer s_wsfe(), e_wsfe(), do_fio();
    double sqrt();

     
    static doublereal fact;
    static integer ifin, icor, ifrz, i__, j;
    static doublereal check, andif;
    extern   int skale_();
    static doublereal anscl;
    static integer imesh, ipred;
    static doublereal anfix, relax;
    static integer iconv, msing;
    static doublereal rnold, anorm, dummy[1], rnorm;
    static integer lj, it, iz;
    static doublereal factor;
    extern   int errchk_();
    static integer ifreez;
    static doublereal relmin;
    static integer noconv;
    extern   int newmsh_();
    static doublereal rlxold;
    static integer lmtfrz;
    static doublereal rstart;
    static integer np1;
    extern   int lsyslv_();
    static doublereal arg;
    static integer inz;

     
    static cilist io___721 = { 0, 0, 0, fmt_495, 0 };
    static cilist io___722 = { 0, 0, 0, fmt_490, 0 };
    static cilist io___726 = { 0, 0, 0, fmt_530, 0 };
    static cilist io___727 = { 0, 0, 0, fmt_510, 0 };
    static cilist io___728 = { 0, 0, 0, fmt_510, 0 };
    static cilist io___733 = { 0, 0, 0, fmt_560, 0 };
    static cilist io___734 = { 0, 0, 0, fmt_510, 0 };
    static cilist io___735 = { 0, 0, 0, fmt_540, 0 };
    static cilist io___737 = { 0, 0, 0, fmt_500, 0 };
    static cilist io___744 = { 0, 0, 0, fmt_520, 0 };
    static cilist io___745 = { 0, 0, 0, fmt_550, 0 };
    static cilist io___749 = { 0, 0, 0, fmt_560, 0 };
    static cilist io___750 = { 0, 0, 0, fmt_560, 0 };
    static cilist io___752 = { 0, 0, 0, fmt_610, 0 };
    static cilist io___753 = { 0, 0, 0, fmt_620, 0 };
    static cilist io___756 = { 0, 0, 0, fmt_570, 0 };
    static cilist io___757 = { 0, 0, 0, fmt_580, 0 };
    static cilist io___758 = { 0, 0, 0, fmt_590, 0 };
    static cilist io___759 = { 0, 0, 0, fmt_600, 0 };
    --fixpnt;
    --ipvtw;
    --integs;
    --ipvtg;
    --accum;
    --dscale;
    --scale;
    --slope;
    --valstr;
    --v;
    --w;
    --g;
    --dqdmz;
    --dqz;
    --deldmz;
    --delz;
    --rhs;
    --dmz;
    --z__;
    --xiold;
    --xi;

     
    relmin = .001;
    rstart = .01;
    lmtfrz = 4;

 

    check = 0.;
    i__1 = (colest_._2) .ntol;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = (colest_._2) .tolin[i__ - 1];
	check = (( d__1 ) >= ( check ) ? ( d__1 ) : ( check )) ;
    }
    imesh = 1;
    iconv = 0;
    if (colnln_ .nonlin == 0) {
	iconv = 1;
    }
    icor = 0;
    noconv = 0;
    msing = 0;

 
 
 


L20:

 

    colnln_ .iter = 0;
    if (colnln_ .nonlin > 0) {
	goto L50;
    }

 
 

    lsyslv_(&msing, &xi[1], &xiold[1], dummy, dummy, &z__[1], &dmz[1], &g[1], 
	    &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[1], &
	    rnorm, &c__0, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    if (msing == 0) {
	goto L400;
    }
L30:
    if (msing < 0) {
	goto L40;
    }
    if (colout_ .iprint < 1) {
	io___721.ciunit = colout_ .iout;
	s_wsfe(&io___721);
	e_wsfe();
    }
    goto L460;
L40:
    if (colout_ .iprint < 1) {
	io___722.ciunit = colout_ .iout;
	s_wsfe(&io___722);
	e_wsfe();
    }
    *iflag = 0;
    return 0;

 
 

L50:
    relax = 1.;

 

    if (colnln_ .icare == 1 || colnln_ .icare == -1) {
	relax = rstart;
    }
    if (iconv == 0) {
	goto L160;
    }

 
 
 
 

    ifreez = 0;

 
 

    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1],
	     &g[1], &w[1], &v[1], &rhs[1], &dqdmz[1], &integs[1], &ipvtg[1], &
	    ipvtw[1], &rnold, &c__1, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

    if (colout_ .iprint < 0) {
	io___726.ciunit = colout_ .iout;
	s_wsfe(&io___726);
	e_wsfe();
    }
    if (colout_ .iprint < 0) {
	io___727.ciunit = colout_ .iout;
	s_wsfe(&io___727);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    goto L70;

 
 
 

L60:
    if (colout_ .iprint < 0) {
	io___728.ciunit = colout_ .iout;
	s_wsfe(&io___728);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    rnold = rnorm;
    i__1 = ifreez + 3;
    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1],
	     &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &
	    ipvtw[1], &rnorm, &i__1, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

L70:
    if (msing != 0) {
	goto L30;
    }
    if (ifreez == 1) {
	goto L80;
    }

 

    ++ colnln_ .iter;
    ifrz = 0;
L80:

 

    i__1 = colapr_ .nz;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z__[i__] += delz[i__];
 
    }
    i__1 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dmz[i__] += deldmz[i__];
 
    }
    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1],
	     &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &
	    ipvtw[1], &rnorm, &c__2, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 
 
 

    if (rnorm < colout_ .precis) {
	goto L390;
    }
    if (rnorm > rnold) {
	goto L130;
    }
    if (ifreez == 1) {
	goto L110;
    }
    ifreez = 1;
    goto L60;

 
 

L110:
    ++ifrz;
    if (ifrz >= lmtfrz) {
	ifreez = 0;
    }
    if (rnold < rnorm * 4.) {
	ifreez = 0;
    }

 

    i__1 = (colest_._2) .ntol;
    for (it = 1; it <= i__1; ++it) {
	inz = (colest_._2) .ltol[it - 1];
	i__2 = colapr_ .nz;
	i__3 = (colord_._2) .mstar;
	for (iz = inz; i__3 < 0 ? iz >= i__2 : iz <= i__2; iz += i__3) {
	    if ((d__1 = delz[iz], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (colest_._2) .tolin[it - 1] * ((
		    d__2 = z__[iz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.)) {
		goto L60;
	    }
 
	}
    }

 

    if (colout_ .iprint < 1) {
	io___733.ciunit = colout_ .iout;
	s_wsfe(&io___733);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    goto L400;

 

L130:
    if (colout_ .iprint < 0) {
	io___734.ciunit = colout_ .iout;
	s_wsfe(&io___734);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (colout_ .iprint < 0) {
	io___735.ciunit = colout_ .iout;
	s_wsfe(&io___735);
	e_wsfe();
    }
    iconv = 0;
    relax = rstart;
    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	z__[i__] -= delz[i__];
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	dmz[i__] -= deldmz[i__];
 
    }

 

    np1 = colapr_ .n + 1;
    i__3 = np1;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	xiold[i__] = xi[i__];
    }
    colapr_ .nold = colapr_ .n;

    colnln_ .iter = 0;

 
 
 

L160:
    if (colout_ .iprint < 0) {
	io___737.ciunit = colout_ .iout;
	s_wsfe(&io___737);
	e_wsfe();
    }
    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1],
	     &g[1], &w[1], &v[1], &rhs[1], &dqdmz[1], &integs[1], &ipvtg[1], &
	    ipvtw[1], &rnold, &c__1, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    if (msing != 0) {
	goto L30;
    }

 

    if (colnln_ .iguess == 1) {
	colnln_ .iguess = 0;
    }

 

    skale_(& colapr_ .n, & (colord_._2) .mstar, & (colord_._2) .kd, &z__[1], &xi[1], &
	    scale[1], &dscale[1]);
    goto L220;

 

L170:
    rnold = rnorm;
    if (colnln_ .iter >= colnln_ .limit) {
	goto L430;
    }

 

    skale_(& colapr_ .n, & (colord_._2) .mstar, & (colord_._2) .kd, &z__[1], &xi[1], &
	    scale[1], &dscale[1]);

 

    anscl = 0.;
    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = delz[i__] * scale[i__];
	anscl += d__1 * d__1;
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = deldmz[i__] * dscale[i__];
	anscl += d__1 * d__1;
 
    }
    anscl = sqrt(anscl / (doublereal) (colapr_ .nz + colapr_ .ndmz));

 

    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &delz[1], &deldmz[1],
	     &g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &
	    ipvtw[1], &rnorm, &c__3, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    if (msing != 0) {
	goto L30;
    }

 

    andif = 0.;
    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = (dqz[i__] - delz[i__]) * scale[i__];
	andif += d__1 * d__1;
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = (dqdmz[i__] - deldmz[i__]) * dscale[i__];
	andif += d__1 * d__1;
 
    }
    andif = sqrt(andif / (doublereal) (colapr_ .nz + colapr_ .ndmz) + 
	    colout_ .precis);
    relax = relax * anscl / andif;
    if (relax > 1.) {
	relax = 1.;
    }
L220:
    rlxold = relax;
    ipred = 1;
    ++ colnln_ .iter;

 


    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	z__[i__] += relax * delz[i__];
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	dmz[i__] += relax * deldmz[i__];
 
    }
L250:
    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &dqz[1], &dqdmz[1], &
	    g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[
	    1], &rnorm, &c__2, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    lsyslv_(&msing, &xi[1], &xiold[1], &z__[1], &dmz[1], &dqz[1], &dqdmz[1], &
	    g[1], &w[1], &v[1], &rhs[1], dummy, &integs[1], &ipvtg[1], &ipvtw[
	    1], &rnorm, &c__4, fsub, dfsub, gsub, dgsub, guess);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    anorm = 0.;
    anfix = 0.;
    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = delz[i__] * scale[i__];
	anorm += d__1 * d__1;
 
	d__1 = dqz[i__] * scale[i__];
	anfix += d__1 * d__1;
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	d__1 = deldmz[i__] * dscale[i__];
	anorm += d__1 * d__1;
 
	d__1 = dqdmz[i__] * dscale[i__];
	anfix += d__1 * d__1;
 
    }
    anorm = sqrt(anorm / (doublereal) (colapr_ .nz + colapr_ .ndmz));
    anfix = sqrt(anfix / (doublereal) (colapr_ .nz + colapr_ .ndmz));
    if (icor == 1) {
	goto L280;
    }
    if (colout_ .iprint < 0) {
	io___744.ciunit = colout_ .iout;
	s_wsfe(&io___744);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&anorm, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&anfix, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    goto L290;
L280:
    if (colout_ .iprint < 0) {
	io___745.ciunit = colout_ .iout;
	s_wsfe(&io___745);
	do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&anorm, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&anfix, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&rnold, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
L290:
    icor = 0;

 

    if (anfix < colout_ .precis || rnorm < colout_ .precis) {
	goto L390;
    }
    if (anfix > anorm) {
	goto L300;
    }

 
 

    if (anfix <= check) {
	goto L350;
    }

 
 

    if (ipred != 1) {
	goto L170;
    }
L300:
    if (colnln_ .iter >= colnln_ .limit) {
	goto L430;
    }

 

    ipred = 0;
    arg = (anfix / anorm - 1.) / relax + 1.;
    if (arg < 0.) {
	goto L170;
    }
 
    d__1 = relax;
    if (arg <= relax * .25 + d__1 * d__1 * .125) {
	goto L310;
    }
    factor = sqrt(arg * 8. + 1.) - 1.;
    if ((d__1 = factor - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < factor * .1) {
	goto L170;
    }
    if (factor < .5) {
	factor = .5;
    }
    relax /= factor;
    goto L320;
L310:
    if (relax >= .9) {
	goto L170;
    }
    relax = 1.;
L320:
    icor = 1;
    if (relax < relmin) {
	goto L440;
    }
    fact = relax - rlxold;
    i__3 = colapr_ .nz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	z__[i__] += fact * delz[i__];
 
    }
    i__3 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__3; ++i__) {
	dmz[i__] += fact * deldmz[i__];
 
    }
    rlxold = relax;
    goto L250;

 

L350:
    i__3 = (colest_._2) .ntol;
    for (it = 1; it <= i__3; ++it) {
	inz = (colest_._2) .ltol[it - 1];
	i__2 = colapr_ .nz;
	i__1 = (colord_._2) .mstar;
	for (iz = inz; i__1 < 0 ? iz >= i__2 : iz <= i__2; iz += i__1) {
	    if ((d__1 = dqz[iz], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (colest_._2) .tolin[it - 1] * ((d__2 
		    = z__[iz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.)) {
		goto L170;
	    }
 
	}
    }

 

    if (colout_ .iprint < 1) {
	io___749.ciunit = colout_ .iout;
	s_wsfe(&io___749);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	e_wsfe();
    }

 
 

    i__1 = colapr_ .nz;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z__[i__] += dqz[i__];
 
    }
    i__1 = colapr_ .ndmz;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dmz[i__] += dqdmz[i__];
 
    }
L390:
    if ((anfix < colout_ .precis || rnorm < colout_ .precis) && 
	    colout_ .iprint < 1) {
	io___750.ciunit = colout_ .iout;
	s_wsfe(&io___750);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    iconv = 1;
    if (colnln_ .icare == -1) {
	colnln_ .icare = 0;
    }

 
 

L400:
    if (colout_ .iprint >= 0) {
	goto L420;
    }
    i__1 = (colord_._2) .mstar;
    for (j = 1; j <= i__1; ++j) {
	io___752.ciunit = colout_ .iout;
	s_wsfe(&io___752);
	do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
	e_wsfe();
 
	io___753.ciunit = colout_ .iout;
	s_wsfe(&io___753);
	i__2 = colapr_ .nz;
	i__3 = (colord_._2) .mstar;
	for (lj = j; i__3 < 0 ? lj >= i__2 : lj <= i__2; lj += i__3) {
	    do_fio(&c__1, (char *)&z__[lj], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }

 

L420:
    ifin = 1;
    if (imesh == 2) {
	errchk_(&xi[1], &z__[1], &dmz[1], &valstr[1], &ifin);
    }
    if (imesh == 1 || ifin == 0 && colnln_ .icare != 2) {
	goto L460;
    }
    *iflag = 1;
    return 0;

 

L430:
    if (colout_ .iprint < 1) {
	io___756.ciunit = colout_ .iout;
	s_wsfe(&io___756);
	do_fio(&c__1, (char *)& colnln_ .iter, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    goto L450;
L440:
    if (colout_ .iprint < 1) {
	io___757.ciunit = colout_ .iout;
	s_wsfe(&io___757);
	do_fio(&c__1, (char *)&relax, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&relmin, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
L450:
    *iflag = -2;
    ++noconv;
    if (colnln_ .icare == 2 && noconv > 1) {
	return 0;
    }
    if (colnln_ .icare == 0) {
	colnln_ .icare = -1;
    }

 

L460:
    np1 = colapr_ .n + 1;
    i__3 = np1;
    for (i__ = 1; i__ <= i__3; ++i__) {
 
	xiold[i__] = xi[i__];
    }
    colapr_ .nold = colapr_ .n;

 
 

    imesh = 1;
    if (iconv == 0 || colmsh_ .mshnum >= colmsh_ .mshlmt || colmsh_ .mshalt >=
	     colmsh_ .mshlmt) {
	imesh = 2;
    }
    if (colmsh_ .mshalt >= colmsh_ .mshlmt && colmsh_ .mshnum < 
	    colmsh_ .mshlmt) {
	colmsh_ .mshalt = 1;
    }
    newmsh_(&imesh, &xi[1], &xiold[1], &z__[1], &dmz[1], &valstr[1], &slope[1]
	    , &accum[1], nfxpnt, &fixpnt[1]);

 

    if (colapr_ .n <= colapr_ .nmax) {
	goto L480;
    }
    colapr_ .n /= 2;
    *iflag = -1;
    if (iconv == 0 && colout_ .iprint < 1) {
	io___758.ciunit = colout_ .iout;
	s_wsfe(&io___758);
	e_wsfe();
    }
    if (iconv == 1 && colout_ .iprint < 1) {
	io___759.ciunit = colout_ .iout;
	s_wsfe(&io___759);
	e_wsfe();
    }
    return 0;
L480:
    if (iconv == 0) {
	imesh = 1;
    }
    if (colnln_ .icare == 1) {
	iconv = 0;
    }
    goto L20;
 
}  

  int skale_(n, mstar, kd, z__, xi, scale, dscale)
integer *n, *mstar, *kd;
doublereal *z__, *xi, *scale, *dscale;
{
     
    integer z_dim1, z_offset, scale_dim1, scale_offset, dscale_dim1, 
	    dscale_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

     
    static doublereal basm[5], scal;
    static integer idmz;
    static doublereal h__;
    static integer j, l, icomp, mj, iz, np1;
    scale_dim1 = *mstar;
    scale_offset = scale_dim1 + 1;
    scale -= scale_offset;
    z_dim1 = *mstar;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    dscale_dim1 = *kd;
    dscale_offset = dscale_dim1 + 1;
    dscale -= dscale_offset;
    --xi;

     
    basm[0] = 1.;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	iz = 1;
	h__ = xi[j + 1] - xi[j];
	i__2 = (colord_._3) .mmax;
	for (l = 1; l <= i__2; ++l) {
	    basm[l] = basm[l - 1] * h__ / (doublereal) l;
 
	}
	i__2 = (colord_._3) .ncomp;
	for (icomp = 1; icomp <= i__2; ++icomp) {
	    scal = ((d__1 = z__[iz + j * z_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = z__[iz 
		    + (j + 1) * z_dim1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) * .5 + 1.;
	    mj = (colord_._3) .m[icomp - 1];
	    i__3 = mj;
	    for (l = 1; l <= i__3; ++l) {
		scale[iz + j * scale_dim1] = basm[l - 1] / scal;
		++iz;
 
	    }
	    scal = basm[mj] / scal;
	    i__3 = *kd;
	    i__4 = (colord_._3) .ncomp;
	    for (idmz = icomp; i__4 < 0 ? idmz >= i__3 : idmz <= i__3; idmz +=
		     i__4) {
		dscale[idmz + j * dscale_dim1] = scal;
 
	    }
 
	}
 
    }
    np1 = *n + 1;
    i__1 = *mstar;
    for (iz = 1; iz <= i__1; ++iz) {
	scale[iz + np1 * scale_dim1] = scale[iz + *n * scale_dim1];
 
    }
    return 0;
}  

 
 
 
 
 

  int newmsh_(mode, xi, xiold, z__, dmz, valstr, slope, accum, 
	nfxpnt, fixpnt)
integer *mode;
doublereal *xi, *xiold, *z__, *dmz, *valstr, *slope, *accum;
integer *nfxpnt;
doublereal *fixpnt;
{
     
    static char fmt_360[] = "(/\002 THE FORMER MESH (OF\002,i5,\002 SUBINTERVALS),\002,100(/8f12.6))";
    static char fmt_370[] = "(/\002  EXPECTED N TOO LARGE \002)";
    static char fmt_350[] = "(/\002 MESH SELECTION INFO,\002/\002 DEGREE OF EQUIDISTRIBUTION = \002,f8.5,\002 PREDICTION FOR REQUIRED N =\002,i8)";
    static char fmt_340[] = "(/\002 THE NEW MESH (OF\002,i5,\002 SUBINTERVALS), \002,100(/8f12.6))";

     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2, d__3, d__4, d__5;

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double pow_dd();

     
    static doublereal accl, accr;
    static integer lold;
    static doublereal avrg;
    static integer nmin;
    static doublereal temp;
    static integer lnew;
    static doublereal tsum;
    static integer nmax2, nfxp1, i__, j, l;
    static doublereal x, hiold;
    static integer ileft, iflip, nregn;
    static doublereal xleft, d1[40], d2[40], dummy[1];
    static integer n2, noldp1, jj, in;
    static doublereal dx;
    static integer jz, naccum;
    static doublereal degequ;
    extern   int horder_();
    static integer iright, lcarry;
    static doublereal oneovh, hd6, xright;
    static integer kstore;
    extern   int approx_();
    static integer np1;
    static doublereal slphmx;
    static integer nmx;

     
    static cilist io___772 = { 0, 0, 0, fmt_360, 0 };
    static cilist io___784 = { 0, 0, 0, fmt_370, 0 };
    static cilist io___801 = { 0, 0, 0, fmt_350, 0 };
    static cilist io___812 = { 0, 0, 0, fmt_340, 0 };
     
    --fixpnt;
    --accum;
    --slope;
    --valstr;
    --dmz;
    --z__;
    --xiold;
    --xi;

     
    nfxp1 = *nfxpnt + 1;
    switch ((int)*mode) {
	case 1:  goto L180;
	case 2:  goto L100;
	case 3:  goto L50;
	case 4:  goto L20;
	case 5:  goto L10;
    }

 

L10:
    colmsh_ .mshlmt = 1;

 

L20:
    if (colnln_ .iguess < 2) {
	goto L40;
    }

 

    noldp1 = colapr_ .nold + 1;
    if (colout_ .iprint < 1) {
	io___772.ciunit = colout_ .iout;
	s_wsfe(&io___772);
	do_fio(&c__1, (char *)& colapr_ .nold, (ftnlen)sizeof(integer));
	i__1 = noldp1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_fio(&c__1, (char *)&xiold[i__], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }
    if (colnln_ .iguess != 3) {
	goto L40;
    }

 
 
 

    colapr_ .n = colapr_ .nold / 2;
    i__ = 0;
    i__1 = colapr_ .nold;
    for (j = 1; j <= i__1; j += 2) {
	++i__;
 
	xi[i__] = xiold[j];
    }
L40:
    np1 = colapr_ .n + 1;
    xi[1] = (colsid_._2) .aleft;
    xi[np1] = (colsid_._2) .aright;
    goto L320;

 
 

L50:
    if (colapr_ .n < nfxp1) {
	colapr_ .n = nfxp1;
    }
    np1 = colapr_ .n + 1;
    xi[1] = (colsid_._2) .aleft;
    ileft = 1;
    xleft = (colsid_._2) .aleft;

 

    i__1 = nfxp1;
    for (j = 1; j <= i__1; ++j) {
	xright = (colsid_._2) .aright;
	iright = np1;
	if (j == nfxp1) {
	    goto L60;
	}
	xright = fixpnt[j];

 

 
 

	nmin = (integer) ((xright - (colsid_._2) .aleft) / ((colsid_._2) .aright - 
		(colsid_._2) .aleft) * (doublereal) colapr_ .n + 1.5);
	if (nmin > colapr_ .n - *nfxpnt + j) {
	    nmin = colapr_ .n - *nfxpnt + j;
	}
 
	i__2 = ileft + 1;
	iright = (( i__2 ) >= ( nmin ) ? ( i__2 ) : ( nmin )) ;
L60:
	xi[iright] = xright;

 

 

	nregn = iright - ileft - 1;
	if (nregn == 0) {
	    goto L80;
	}
	dx = (xright - xleft) / (doublereal) (nregn + 1);
	i__2 = nregn;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    xi[ileft + i__] = xleft + (doublereal) i__ * dx;
	}
L80:
	ileft = iright;
	xleft = xright;
 
    }
    goto L320;

 

L100:
    n2 = colapr_ .n << 1;

 

    if (n2 <= colapr_ .nmax) {
	goto L120;
    }

 

    if (*mode == 2) {
	goto L110;
    }
    colapr_ .n = colapr_ .nmax / 2;
    goto L220;
L110:
    if (colout_ .iprint < 1) {
	io___784.ciunit = colout_ .iout;
	s_wsfe(&io___784);
	e_wsfe();
    }
    colapr_ .n = n2;
    return 0;

 
 
 
 
 

L120:
    if (colmsh_ .mshflg == 0) {
	goto L140;
    }

 
 

    kstore = 1;
    i__1 = colapr_ .nold;
    for (i__ = 1; i__ <= i__1; ++i__) {
	hd6 = (xiold[i__ + 1] - xiold[i__]) / 6.;
	x = xiold[i__] + hd6;
	approx_(&i__, &x, &valstr[kstore], colbas_ .asave, dummy, &xiold[1], &
		colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp,
		 & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, &
		c__0);
	x += hd6 * 4.;
	kstore += (colord_._2) .mstar * 3;
	approx_(&i__, &x, &valstr[kstore], & colbas_ .asave[84], dummy, &xiold[
		1], & colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, &
		(colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &
		c__4, dummy, &c__0);
	kstore += (colord_._2) .mstar;
 
    }
    goto L160;

 
 
 

L140:
    kstore = 1;
    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x = xi[i__];
	hd6 = (xi[i__ + 1] - xi[i__]) / 6.;
	for (j = 1; j <= 4; ++j) {
	    x += hd6;
	    if (j == 3) {
		x += hd6;
	    }
	    approx_(&i__, &x, &valstr[kstore], & colbas_ .asave[j * 28 - 28], 
		    dummy, &xiold[1], & colapr_ .nold, &z__[1], &dmz[1], &
		    (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, &
		    (colord_._2) .mstar, &c__4, dummy, &c__0);
	    kstore += (colord_._2) .mstar;
 
	}
    }
L160:
    colmsh_ .mshflg = 0;
    colmsh_ .mshnum = 1;
    *mode = 2;

 

    j = 2;
    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xi[j] = (xiold[i__] + xiold[i__ + 1]) / 2.;
	xi[j + 1] = xiold[i__ + 1];
 
	j += 2;
    }
    colapr_ .n = n2;
    goto L320;

 

L180:
    if (colapr_ .nold == 1) {
	goto L100;
    }
    if (colapr_ .nold <= *nfxpnt << 1) {
	goto L100;
    }

 
 
 

 

    i__ = 1;
    hiold = xiold[2] - xiold[1];
    horder_(&c__1, d1, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k);
    hiold = xiold[3] - xiold[2];
    horder_(&c__2, d2, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k);
    accum[1] = 0.;
    slope[1] = 0.;
    oneovh = 2. / (xiold[3] - xiold[1]);
    i__1 = (colest_._2) .ntol;
    for (j = 1; j <= i__1; ++j) {
	jj = (colest_._2) .jtol[j - 1];
	jz = (colest_._2) .ltol[j - 1];
 
 
	d__5 = (d__1 = d2[jj - 1] - d1[jj - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * (colest_._2) .wgtmsh[
		j - 1] * oneovh / ((d__2 = z__[jz], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1.);
	d__3 = slope[1], d__4 = pow_dd(&d__5, & (colest_._2) .root[j - 1]);
	slope[1] = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
    }
    slphmx = slope[1] * (xiold[2] - xiold[1]);
    accum[2] = slphmx;
    iflip = 1;

 
 

    i__1 = colapr_ .nold;
    for (i__ = 2; i__ <= i__1; ++i__) {
	hiold = xiold[i__ + 1] - xiold[i__];
	if (iflip == -1) {
	    horder_(&i__, d1, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k);
	}
	if (iflip == 1) {
	    horder_(&i__, d2, &hiold, &dmz[1], & (colord_._2) .ncomp, & (colord_._2) .k);
	}
	oneovh = 2. / (xiold[i__ + 1] - xiold[i__ - 1]);
	slope[i__] = 0.;

 

	i__2 = (colest_._2) .ntol;
	for (j = 1; j <= i__2; ++j) {
	    jj = (colest_._2) .jtol[j - 1];
	    jz = (colest_._2) .ltol[j - 1] + (i__ - 1) * (colord_._2) .mstar;
 
 
	    d__5 = (d__1 = d2[jj - 1] - d1[jj - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * 
		    (colest_._2) .wgtmsh[j - 1] * oneovh / ((d__2 = z__[jz], (( 
		    d__2 ) >= 0 ? (  		    d__2 ) : -(  		    d__2 )) ) + 1.);
	    d__3 = slope[i__], d__4 = pow_dd(&d__5, & (colest_._2) .root[j - 1]);
	    slope[i__] = (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
	}

 
 

	temp = slope[i__] * (xiold[i__ + 1] - xiold[i__]);
	slphmx = (( slphmx ) >= ( temp ) ? ( slphmx ) : ( temp )) ;
	accum[i__ + 1] = accum[i__] + temp;
 
	iflip = -iflip;
    }
    avrg = accum[colapr_ .nold + 1] / (doublereal) colapr_ .nold;
    degequ = avrg / (( slphmx ) >= ( colout_ .precis ) ? ( slphmx ) : ( colout_ .precis )) ;

 

    naccum = (integer) (accum[colapr_ .nold + 1] + 1.);
    if (colout_ .iprint < 0) {
	io___801.ciunit = colout_ .iout;
	s_wsfe(&io___801);
	do_fio(&c__1, (char *)&degequ, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&naccum, (ftnlen)sizeof(integer));
	e_wsfe();
    }

 

    if (avrg < colout_ .precis) {
	goto L100;
    }
    if (degequ >= .5) {
	goto L100;
    }

 
 

 
    i__1 = colapr_ .nold + 1;
    nmx = (( i__1 ) >= ( naccum ) ? ( i__1 ) : ( naccum ))  / 2;

 


    nmax2 = colapr_ .nmax / 2;

 

 
    i__1 = (( nmax2 ) <= ( colapr_ .nold ) ? ( nmax2 ) : ( colapr_ .nold )) ;
    colapr_ .n = (( i__1 ) <= ( nmx ) ? ( i__1 ) : ( nmx )) ;
L220:
    noldp1 = colapr_ .nold + 1;
    if (colapr_ .n < nfxp1) {
	colapr_ .n = nfxp1;
    }
    ++ colmsh_ .mshnum;

 
 
 
 

    if (colapr_ .n < colapr_ .nold) {
	colmsh_ .mshnum = colmsh_ .mshlmt;
    }
    if (colapr_ .n > colapr_ .nold / 2) {
	colmsh_ .mshalt = 1;
    }
    if (colapr_ .n == colapr_ .nold / 2) {
	++ colmsh_ .mshalt;
    }
    colmsh_ .mshflg = 0;

 

 
 

    in = 1;
    accl = 0.;
    lold = 2;
    xi[1] = (colsid_._2) .aleft;
    xi[colapr_ .n + 1] = (colsid_._2) .aright;
    i__1 = nfxp1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (i__ == nfxp1) {
	    goto L250;
	}
	i__2 = noldp1;
	for (j = lold; j <= i__2; ++j) {
	    lnew = j;
	    if (fixpnt[i__] <= xiold[j]) {
		goto L240;
	    }
 
	}
L240:
	accr = accum[lnew] + (fixpnt[i__] - xiold[lnew]) * slope[lnew - 1];
	nregn = (integer) ((accr - accl) / accum[noldp1] * (doublereal) 
		colapr_ .n - .5);
 
	i__2 = nregn, i__3 = colapr_ .n - in - nfxp1 + i__;
	nregn = (( i__2 ) <= ( i__3 ) ? ( i__2 ) : ( i__3 )) ;
	xi[in + nregn + 1] = fixpnt[i__];
	goto L260;
L250:
	accr = accum[noldp1];
	lnew = noldp1;
	nregn = colapr_ .n - in;
L260:
	if (nregn == 0) {
	    goto L300;
	}
	temp = accl;
	tsum = (accr - accl) / (doublereal) (nregn + 1);
	i__2 = nregn;
	for (j = 1; j <= i__2; ++j) {
	    ++in;
	    temp += tsum;
	    i__3 = lnew;
	    for (l = lold; l <= i__3; ++l) {
		lcarry = l;
		if (temp <= accum[l]) {
		    goto L280;
		}
 
	    }
L280:
	    lold = lcarry;
 
	    xi[in] = xiold[lold - 1] + (temp - accum[lold - 1]) / slope[lold 
		    - 1];
	}
L300:
	++in;
	accl = accr;
	lold = lnew;
 
    }
    *mode = 1;
L320:
    np1 = colapr_ .n + 1;
    if (colout_ .iprint < 1) {
	io___812.ciunit = colout_ .iout;
	s_wsfe(&io___812);
	do_fio(&c__1, (char *)& colapr_ .n, (ftnlen)sizeof(integer));
	i__1 = np1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_fio(&c__1, (char *)&xi[i__], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }
    colapr_ .nz = (colord_._2) .mstar * (colapr_ .n + 1);
    colapr_ .ndmz = (colord_._2) .kd * colapr_ .n;
    return 0;
 
}  

  int consts_(k, rho, coef)
integer *k;
doublereal *rho, *coef;
{
     

    static doublereal cnsts1[28] = { .25,.0625,.072169,.018342,.019065,.05819,
	    .0054658,.005337,.01889,.027792,.0016095,.0014964,.0075938,
	    .0057573,.018342,.004673,4.15e-4,.001919,.001468,.006371,.00461,
	    1.342e-4,1.138e-4,4.889e-4,4.177e-4,.001374,.001654,.002863 };
    static doublereal cnsts2[28] = { .125,.002604,.008019,2.17e-5,7.453e-5,
	    5.208e-4,9.689e-8,3.689e-7,3.1e-6,2.451e-5,2.691e-10,1.12e-9,
	    1.076e-8,9.405e-8,1.033e-6,5.097e-13,2.29e-12,2.446e-11,2.331e-10,
	    2.936e-9,3.593e-8,7.001e-16,3.363e-15,3.921e-14,4.028e-13,
	    5.646e-12,7.531e-11,1.129e-9 };

     
    integer coef_dim1, coef_offset, i__1, i__2;

     
    static integer koff, mtot, i__, j, l;
    extern   int rkbas_();
    static integer jcomp, ltoli;
    static doublereal dummy[1];
    static integer mj, iz;
    extern   int vmonde_();
    coef_dim1 = *k;
    coef_offset = coef_dim1 + 1;
    coef -= coef_offset;
    --rho;

     

 

    koff = *k * (*k + 1) / 2;
    iz = 1;
    i__1 = (colord_._4) .ncomp;
    for (j = 1; j <= i__1; ++j) {
	mj = (colord_._4) .m[j - 1];
	i__2 = mj;
	for (l = 1; l <= i__2; ++l) {
	    (colest_._2) .wgterr[iz - 1] = cnsts1[koff - mj + l - 1];
	    ++iz;
 
	}
    }

 

    jcomp = 1;
    mtot = (colord_._4) .m[0];
    i__2 = (colest_._2) .ntol;
    for (i__ = 1; i__ <= i__2; ++i__) {
	ltoli = (colest_._2) .ltol[i__ - 1];
L20:
	if (ltoli <= mtot) {
	    goto L30;
	}
	++jcomp;
	mtot += (colord_._4) .m[jcomp - 1];
	goto L20;
L30:
	(colest_._2) .jtol[i__ - 1] = jcomp;
	(colest_._2) .wgtmsh[i__ - 1] = cnsts2[koff + ltoli - mtot - 1] * 10. / 
		(colest_._2) .tolin[i__ - 1];
	(colest_._2) .root[i__ - 1] = 1. / (doublereal) (*k + mtot - ltoli + 1);
 
    }

 

    switch ((int)*k) {
	case 1:  goto L50;
	case 2:  goto L60;
	case 3:  goto L70;
	case 4:  goto L80;
	case 5:  goto L90;
	case 6:  goto L100;
	case 7:  goto L110;
    }
L50:
    rho[1] = 0.;
    goto L120;
L60:
    rho[2] = .57735026918962576451;
    rho[1] = -rho[2];
    goto L120;
L70:
    rho[3] = .77459666924148337704;
    rho[2] = 0.;
    rho[1] = -rho[3];
    goto L120;
L80:
    rho[4] = .86113631159405257523;
    rho[3] = .3399810435848562648;
    rho[2] = -rho[3];
    rho[1] = -rho[4];
    goto L120;
L90:
    rho[5] = .9061798459386639928;
    rho[4] = .53846931010568309104;
    rho[3] = 0.;
    rho[2] = -rho[4];
    rho[1] = -rho[5];
    goto L120;
L100:
    rho[6] = .93246951420315202781;
    rho[5] = .66120938646626451366;
    rho[4] = .23861918608319690863;
    rho[3] = -rho[4];
    rho[2] = -rho[5];
    rho[1] = -rho[6];
    goto L120;
L110:
    rho[7] = .949107991234275852452;
    rho[6] = .74153118559939443986;
    rho[5] = .4058451513773971669;
    rho[4] = 0.;
    rho[3] = -rho[5];
    rho[2] = -rho[6];
    rho[1] = -rho[7];
L120:

 

    i__2 = *k;
    for (j = 1; j <= i__2; ++j) {
	rho[j] = (rho[j] + 1.) * .5;
 
    }

 
 

    i__2 = *k;
    for (j = 1; j <= i__2; ++j) {
	i__1 = *k;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    coef[i__ + j * coef_dim1] = 0.;
	}
	coef[j + j * coef_dim1] = 1.;
	vmonde_(&rho[1], &coef[j * coef_dim1 + 1], k);
 
    }
    rkbas_(&c_b89, &coef[coef_offset], k, & (colord_._4) .mmax, colbas_ .b, dummy, &
	    c__0);
    i__2 = *k;
    for (i__ = 1; i__ <= i__2; ++i__) {
	rkbas_(&rho[i__], &coef[coef_offset], k, & (colord_._4) .mmax, &
		colbas_ .acol[i__ * 28 - 28], dummy, &c__0);
 
    }
    rkbas_(&c_b1934, &coef[coef_offset], k, & (colord_._4) .mmax, colbas_ .asave, 
	    dummy, &c__0);
    rkbas_(&c_b1936, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[
	    28], dummy, &c__0);
    rkbas_(&c_b1938, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[
	    56], dummy, &c__0);
    rkbas_(&c_b1940, &coef[coef_offset], k, & (colord_._4) .mmax, & colbas_ .asave[
	    84], dummy, &c__0);
    return 0;
}  

  int errchk_(xi, z__, dmz, valstr, ifin)
doublereal *xi, *z__, *dmz, *valstr;
integer *ifin;
{
     
    static char fmt_130[] = "(/\002 THE ESTIMATED ERRORS ARE,\002)";
    static char fmt_120[] = "(\002 U(\002,i2,\002) -\002,4d12.4)";

     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    integer s_wsfe(), e_wsfe(), do_fio();

     
    static integer knew, ltjz, iback, j, i__, l;
    static doublereal x;
    static integer ltolj;
    static doublereal dummy[1];
    static integer lj, mj;
    static doublereal errest[40];
    static integer kstore;
    extern   int approx_();
    static doublereal err[40];

     
    static cilist io___837 = { 0, 0, 0, fmt_130, 0 };
    static cilist io___840 = { 0, 0, 0, fmt_120, 0 };
    --valstr;
    --dmz;
    --z__;
    --xi;

     
    *ifin = 1;
    colmsh_ .mshflg = 1;
    i__1 = (colord_._2) .mstar;
    for (j = 1; j <= i__1; ++j) {
 
	errest[j - 1] = 0.;
    }
    i__1 = colapr_ .n;
    for (iback = 1; iback <= i__1; ++iback) {
	i__ = colapr_ .n + 1 - iback;

	knew = ((i__ - 1 << 2) + 2) * (colord_._2) .mstar + 1;
	kstore = ((i__ - 1 << 1) + 1) * (colord_._2) .mstar + 1;
	x = xi[i__] + (xi[i__ + 1] - xi[i__]) * 2. / 3.;
	approx_(&i__, &x, &valstr[knew], & colbas_ .asave[56], dummy, &xi[1], &
		colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, &
		(colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, &
		c__0);
	i__2 = (colord_._2) .mstar;
	for (l = 1; l <= i__2; ++l) {
	    err[l - 1] = (colest_._2) .wgterr[l - 1] * (d__1 = valstr[knew] - 
		    valstr[kstore], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    ++knew;
	    ++kstore;
 
	}
	knew = ((i__ - 1 << 2) + 1) * (colord_._2) .mstar + 1;
	kstore = (i__ - 1 << 1) * (colord_._2) .mstar + 1;
	x = xi[i__] + (xi[i__ + 1] - xi[i__]) / 3.;
	approx_(&i__, &x, &valstr[knew], & colbas_ .asave[28], dummy, &xi[1], &
		colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, &
		(colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__4, dummy, &
		c__0);
	i__2 = (colord_._2) .mstar;
	for (l = 1; l <= i__2; ++l) {
	    err[l - 1] += (colest_._2) .wgterr[l - 1] * (d__1 = valstr[knew] - 
		    valstr[kstore], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    ++knew;
	    ++kstore;
 
	}

 

	i__2 = (colord_._2) .mstar;
	for (l = 1; l <= i__2; ++l) {
 
	    d__1 = errest[l - 1], d__2 = err[l - 1];
	    errest[l - 1] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	}

 
 

	if (*ifin == 0) {
	    goto L60;
	}
	i__2 = (colest_._2) .ntol;
	for (j = 1; j <= i__2; ++j) {
	    ltolj = (colest_._2) .ltol[j - 1];
	    ltjz = ltolj + (i__ - 1) * (colord_._2) .mstar;
	    if (err[ltolj - 1] > (colest_._2) .tolin[j - 1] * ((d__1 = z__[ltjz], 
		    (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + 1.)) {
		*ifin = 0;
	    }
 
	}
L60:
	;
    }
    if (colout_ .iprint >= 0) {
	return 0;
    }
    io___837.ciunit = colout_ .iout;
    s_wsfe(&io___837);
    e_wsfe();
    lj = 1;
    i__1 = (colord_._2) .ncomp;
    for (j = 1; j <= i__1; ++j) {
	mj = lj - 1 + (colord_._2) .m[j - 1];
	io___840.ciunit = colout_ .iout;
	s_wsfe(&io___840);
	do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
	i__2 = mj;
	for (l = lj; l <= i__2; ++l) {
	    do_fio(&c__1, (char *)&errest[l - 1], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
	lj = mj + 1;
 
    }
    return 0;
 
}  

 
 
 
 

  int lsyslv_(msing, xi, xiold, z__, dmz, delz, deldmz, g, w, 
	v, rhs, dmzo, integs, ipvtg, ipvtw, rnorm, mode, fsub, dfsub, gsub, 
	dgsub, guess)
integer *msing;
doublereal *xi, *xiold, *z__, *dmz, *delz, *deldmz, *g, *w, *v, *rhs, *dmzo;
integer *integs, *ipvtg, *ipvtw;
doublereal *rnorm;
integer *mode;
  int (*fsub) (), (*dfsub) (), (*gsub) (), (*dgsub) (), (*
	guess) ();
{
     
    integer i__1, i__2, i__3;
    doublereal d__1;

     
    double sqrt();

     
    static integer iold;
    static doublereal gval;
    static integer ncol, idmz, irhs;
    static doublereal hrho, xcol, zval[40];
    static integer izet, nrow;
    static doublereal f[40], h__;
    static integer i__, j, l, lside;
    static doublereal dmval[20], value;
    static integer idmzo;
    static doublereal dummy[1];
    static integer m1;
    static doublereal df[800];
    static integer ig, jj;
    static doublereal at[28];
    static integer iv, iw;
    extern   int gblock_();
    static integer lw;
    extern   int fcblok_();
    static integer iz;
    extern   int sbblok_(), gderiv_(), vwblok_(), dmzsol_(), 
	    approx_();
    static doublereal dgz[40], xii;
     
    --ipvtw;
    --ipvtg;
    integs -= 4;
    --dmzo;
    --rhs;
    --v;
    --w;
    --g;
    --deldmz;
    --delz;
    --dmz;
    --z__;
    --xiold;
    --xi;

     
    m1 = *mode + 1;
    switch ((int)m1) {
	case 1:  goto L10;
	case 2:  goto L30;
	case 3:  goto L30;
	case 4:  goto L30;
	case 5:  goto L310;
    }

 

L10:
    i__1 = (colord_._2) .mstar;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	zval[i__ - 1] = 0.;
    }

 

L30:
    idmz = 1;
    idmzo = 1;
    irhs = 1;
    ig = 1;
    iw = 1;
    iv = 1;
    (colsid_._3) .izeta = 1;
    lside = 0;
    iold = 1;
    ncol = (colord_._2) .mstar << 1;
    *rnorm = 0.;
    if (*mode > 1) {
	goto L80;
    }

 

    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	integs[i__ * 3 + 2] = ncol;
	if (i__ < colapr_ .n) {
	    goto L40;
	}
	integs[colapr_ .n * 3 + 3] = ncol;
	lside = (colord_._2) .mstar;
	goto L60;
L40:
	integs[i__ * 3 + 3] = (colord_._2) .mstar;
L50:
	if (lside == (colord_._2) .mstar) {
	    goto L60;
	}
	if ((colsid_._3) .zeta[lside] >= xi[i__] + colout_ .precis) {
	    goto L60;
	}
	++lside;
	goto L50;
L60:
	nrow = (colord_._2) .mstar + lside;
 
	integs[i__ * 3 + 1] = nrow;
    }
L80:
    if (*mode == 2) {
	goto L90;
    }

 

    lw = (colord_._2) .kd * (colord_._2) .kd * colapr_ .n;
    i__1 = lw;
    for (l = 1; l <= i__1; ++l) {
 
	w[l] = 0.;
    }

 

L90:
    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {

 


	xii = xi[i__];
	h__ = xi[i__ + 1] - xi[i__];
	nrow = integs[i__ * 3 + 1];

 

 

L100:
	if ((colsid_._3) .izeta > (colord_._2) .mstar) {
	    goto L140;
	}
	if ((colsid_._3) .zeta[(colsid_._3) .izeta - 1] > xii + colout_ .precis) {
	    goto L140;
	}

 

	if (*mode == 0) {
	    goto L110;
	}
	if (colnln_ .iguess != 1) {
	    goto L102;
	}

 

	(*guess)(&xii, zval, dmval);
	if (iercol_ .iero > 0) {
	    return 0;
	}
	goto L110;

 

L102:
	if (*mode != 1) {
	    goto L106;
	}
	approx_(&iold, &xii, zval, at, colloc_ .coef, &xiold[1], &
		colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp,
		 & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__2, dummy, &
		c__0);
	goto L110;
L106:
	approx_(&i__, &xii, zval, at, dummy, &xi[1], & colapr_ .n, &z__[1], &
		dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, 
		(colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, &c__0);
 
	if (*mode == 3) {
	    goto L120;
	}

 

L110:
	(*gsub)(& (colsid_._3) .izeta, zval, &gval);
	if (iercol_ .iero > 0) {
	    return 0;
	}
	rhs[colapr_ .ndmz + (colsid_._3) .izeta] = -gval;
 
	d__1 = gval;
	*rnorm += d__1 * d__1;
	if (*mode == 2) {
	    goto L130;
	}

 

L120:
	gderiv_(&g[ig], &nrow, & (colsid_._3) .izeta, zval, dgz, &c__1, dgsub);
	if (iercol_ .iero > 0) {
	    return 0;
	}
L130:
	++ (colsid_._3) .izeta;
	goto L100;

 

L140:
	i__2 = (colord_._2) .k;
	for (j = 1; j <= i__2; ++j) {
	    hrho = h__ * colloc_ .rho[j - 1];
	    xcol = xii + hrho;

 

 


	    if (*mode == 0) {
		goto L200;
	    }
	    if (colnln_ .iguess != 1) {
		goto L160;
	    }

 

	    (*guess)(&xcol, zval, &dmzo[irhs]);
	    if (iercol_ .iero > 0) {
		return 0;
	    }
	    goto L170;

 

L160:
	    if (*mode != 1) {
		goto L190;
	    }
	    approx_(&iold, &xcol, zval, at, colloc_ .coef, &xiold[1], &
		    colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, &
		    (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, &
		    (colord_._2) .mstar, &c__2, &dmzo[irhs], &c__1);

L170:
	    (*fsub)(&xcol, zval, f);
	    if (iercol_ .iero > 0) {
		return 0;
	    }
	    i__3 = (colord_._2) .ncomp;
	    for (jj = 1; jj <= i__3; ++jj) {
		value = dmzo[irhs] - f[jj - 1];
		rhs[irhs] = -value;
 
		d__1 = value;
		*rnorm += d__1 * d__1;
		++irhs;
 
	    }
	    goto L210;

 

L190:
	    approx_(&i__, &xcol, zval, & colbas_ .acol[j * 28 - 28], 
		    colloc_ .coef, &xi[1], & colapr_ .n, &z__[1], &dmz[1], &
		    (colord_._2) .k, & (colord_._2) .ncomp, & (colord_._2) .mmax, (colord_._2) .m, &
		    (colord_._2) .mstar, &c__4, dummy, &c__0);
	    if (*mode == 3) {
		goto L210;
	    }

 

	    (*fsub)(&xcol, zval, f);
	    if (iercol_ .iero > 0) {
		return 0;
	    }
	    i__3 = (colord_._2) .ncomp;
	    for (jj = 1; jj <= i__3; ++jj) {
		value = dmz[irhs] - f[jj - 1];
		rhs[irhs] = -value;
 
		d__1 = value;
		*rnorm += d__1 * d__1;
		++irhs;
 
	    }
	    goto L220;

 

L200:
	    (*fsub)(&xcol, zval, &rhs[irhs]);
	    if (iercol_ .iero > 0) {
		return 0;
	    }
	    irhs += (colord_._2) .ncomp;

 

L210:
	    vwblok_(&xcol, &hrho, &j, &w[iw], &v[iv], &ipvtw[idmz], &
		    (colord_._2) .kd, zval, df, & colbas_ .acol[j * 28 - 28], &dmzo[
		    idmzo], & (colord_._2) .ncomp, dfsub, msing);
	    if (iercol_ .iero > 0) {
		return 0;
	    }
	    if (*msing != 0) {
		return 0;
	    }
L220:
	    ;
	}

 

	if (*mode != 2) {
	    gblock_(&h__, &g[ig], &nrow, & (colsid_._3) .izeta, &w[iw], &v[iv], &
		    (colord_._2) .kd, dummy, &deldmz[idmz], &ipvtw[idmz], &c__1);
	}
	if (i__ < colapr_ .n) {
	    goto L280;
	}
	(colsid_._3) .izsave = (colsid_._3) .izeta;
L240:
	if ((colsid_._3) .izeta > (colord_._2) .mstar) {
	    goto L290;
	}

 

	if (*mode == 0) {
	    goto L250;
	}
	if (colnln_ .iguess != 1) {
	    goto L245;
	}

 

	(*guess)(& (colsid_._3) .aright, zval, dmval);
	if (iercol_ .iero > 0) {
	    return 0;
	}
	goto L250;

 

L245:
	if (*mode != 1) {
	    goto L246;
	}
	i__2 = colapr_ .nold + 1;
	approx_(&i__2, & (colsid_._3) .aright, zval, at, colloc_ .coef, &xiold[1], &
		colapr_ .nold, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp,
		 & (colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, &
		c__0);
	goto L250;
L246:
	i__2 = colapr_ .n + 1;
	approx_(&i__2, & (colsid_._3) .aright, zval, at, colloc_ .coef, &xi[1], &
		colapr_ .n, &z__[1], &dmz[1], & (colord_._2) .k, & (colord_._2) .ncomp, &
		(colord_._2) .mmax, (colord_._2) .m, & (colord_._2) .mstar, &c__1, dummy, &
		c__0);
 
	if (*mode == 3) {
	    goto L260;
	}

 

L250:
	(*gsub)(& (colsid_._3) .izeta, zval, &gval);
	if (iercol_ .iero > 0) {
	    return 0;
	}
	rhs[colapr_ .ndmz + (colsid_._3) .izeta] = -gval;
 
	d__1 = gval;
	*rnorm += d__1 * d__1;
	if (*mode == 2) {
	    goto L270;
	}

 

L260:
	i__2 = (colsid_._3) .izeta + (colord_._2) .mstar;
	gderiv_(&g[ig], &nrow, &i__2, zval, dgz, &c__2, dgsub);
	if (iercol_ .iero > 0) {
	    return 0;
	}
L270:
	++ (colsid_._3) .izeta;
	goto L240;

 

L280:
	ig += nrow * ncol;
	iv += (colord_._2) .kd * (colord_._2) .mstar;
	iw += (colord_._2) .kd * (colord_._2) .kd;
	idmz += (colord_._2) .kd;
	if (*mode == 1) {
	    idmzo += (colord_._2) .kd;
	}
L290:
	;
    }

 

    if (*mode == 0 || *mode == 3) {
	goto L300;
    }
    *rnorm = sqrt(*rnorm / (doublereal) (colapr_ .nz + colapr_ .ndmz));
    if (*mode != 2) {
	goto L300;
    }
    return 0;

 

 

L300:
    fcblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], df, msing);

 

    *msing = -(*msing);
    if (*msing != 0) {
	return 0;
    }

 

L310:
    i__1 = colapr_ .ndmz;
    for (l = 1; l <= i__1; ++l) {
	deldmz[l] = rhs[l];
 
    }
    iz = 1;
    idmz = 1;
    iw = 1;
    izet = 1;
    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nrow = integs[i__ * 3 + 1];
	(colsid_._3) .izeta = nrow + 1 - (colord_._2) .mstar;
	if (i__ == colapr_ .n) {
	    (colsid_._3) .izeta = (colsid_._3) .izsave;
	}
L322:
	if (izet == (colsid_._3) .izeta) {
	    goto L324;
	}
	delz[iz - 1 + izet] = rhs[colapr_ .ndmz + izet];
	++izet;
	goto L322;
L324:
	h__ = xi[i__ + 1] - xi[i__];
	gblock_(&h__, &g[1], &nrow, & (colsid_._3) .izeta, &w[iw], &v[1], &
		(colord_._2) .kd, &delz[iz], &deldmz[idmz], &ipvtw[idmz], &c__2);
	iz += (colord_._2) .mstar;
	idmz += (colord_._2) .kd;
	iw += (colord_._2) .kd * (colord_._2) .kd;
	if (i__ < colapr_ .n) {
	    goto L320;
	}
L326:
	if (izet > (colord_._2) .mstar) {
	    goto L320;
	}
	delz[iz - 1 + izet] = rhs[colapr_ .ndmz + izet];
	++izet;
	goto L326;
L320:
	;
    }

 

    sbblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], &delz[1]);

 

    dmzsol_(& (colord_._2) .kd, & (colord_._2) .mstar, & colapr_ .n, &v[1], &delz[1], &
	    deldmz[1]);

    if (*mode != 1) {
	return 0;
    }
    i__1 = colapr_ .ndmz;
    for (l = 1; l <= i__1; ++l) {
	dmz[l] = dmzo[l];
 
    }
    iz = 1;
    idmz = 1;
    iw = 1;
    izet = 1;
    i__1 = colapr_ .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nrow = integs[i__ * 3 + 1];
	(colsid_._3) .izeta = nrow + 1 - (colord_._2) .mstar;
	if (i__ == colapr_ .n) {
	    (colsid_._3) .izeta = (colsid_._3) .izsave;
	}
L330:
	if (izet == (colsid_._3) .izeta) {
	    goto L340;
	}
	z__[iz - 1 + izet] = dgz[izet - 1];
	++izet;
	goto L330;
L340:
	h__ = xi[i__ + 1] - xi[i__];
	gblock_(&h__, &g[1], &nrow, & (colsid_._3) .izeta, &w[iw], df, & (colord_._2) .kd,
		 &z__[iz], &dmz[idmz], &ipvtw[idmz], &c__2);
	iz += (colord_._2) .mstar;
	idmz += (colord_._2) .kd;
	iw += (colord_._2) .kd * (colord_._2) .kd;
	if (i__ < colapr_ .n) {
	    goto L350;
	}
L342:
	if (izet > (colord_._2) .mstar) {
	    goto L350;
	}
	z__[iz - 1 + izet] = dgz[izet - 1];
	++izet;
	goto L342;
L350:
	;
    }
    sbblok_(&g[1], &integs[4], & colapr_ .n, &ipvtg[1], &z__[1]);

 

    dmzsol_(& (colord_._2) .kd, & (colord_._2) .mstar, & colapr_ .n, &v[1], &z__[1], &dmz[
	    1]);

    return 0;
}  

  int gderiv_(gi, nrow, irow, zval, dgz, mode, dgsub)
doublereal *gi;
integer *nrow, *irow;
doublereal *zval, *dgz;
integer *mode;
  int (*dgsub) ();
{
     
    integer gi_dim1, gi_offset, i__1;

     
    static integer j;
    static doublereal dg[40], dot;
     
    gi_dim1 = *nrow;
    gi_offset = gi_dim1 + 1;
    gi -= gi_offset;
    --zval;
    --dgz;

     
    i__1 = (colord_._5) .mstar;
    for (j = 1; j <= i__1; ++j) {
 
	dg[j - 1] = 0.;
    }

 

    (*dgsub)(& (colsid_._2) .izeta, &zval[1], dg);
    if (iercol_ .iero > 0) {
	return 0;
    }

 

    if (colnln_ .nonlin == 0 || colnln_ .iter > 0) {
	goto L30;
    }
    dot = 0.;
    i__1 = (colord_._5) .mstar;
    for (j = 1; j <= i__1; ++j) {
 
	dot += dg[j - 1] * zval[j];
    }
    dgz[(colsid_._2) .izeta] = dot;

 

L30:
    if (*mode == 2) {
	goto L50;
    }

 
 
 


 

    i__1 = (colord_._5) .mstar;
    for (j = 1; j <= i__1; ++j) {
	gi[*irow + j * gi_dim1] = dg[j - 1];
 
	gi[*irow + ((colord_._5) .mstar + j) * gi_dim1] = 0.;
    }
    return 0;

 

L50:
    i__1 = (colord_._5) .mstar;
    for (j = 1; j <= i__1; ++j) {
	gi[*irow + j * gi_dim1] = 0.;
 
	gi[*irow + ((colord_._5) .mstar + j) * gi_dim1] = dg[j - 1];
    }
    return 0;
}  

  int vwblok_(xcol, hrho, jj, wi, vi, ipvtw, kd, zval, df, 
	acol, dmzo, ncomp, dfsub, msing)
doublereal *xcol, *hrho;
integer *jj;
doublereal *wi, *vi;
integer *ipvtw, *kd;
doublereal *zval, *df, *acol, *dmzo;
integer *ncomp;
  int (*dfsub) ();
integer *msing;
{
     
    integer wi_dim1, wi_offset, vi_dim1, vi_offset, df_dim1, df_offset, i__1, 
	    i__2, i__3, i__4;

     
    static doublereal fact, basm[5];
    static integer jcol;
    extern   int dgefa_();
    static integer j, l;
    extern   int dgesl_();
    static integer jcomp, i0, i1, i2;
    static doublereal ha[28]	 ;
    static integer id;
    static doublereal bl;
    static integer mj, jn, ll, ir, jv, jw, iw, lp1, jdf;
    static doublereal ajl;
     
    --ipvtw;
    vi_dim1 = *kd;
    vi_offset = vi_dim1 + 1;
    vi -= vi_offset;
    wi_dim1 = *kd;
    wi_offset = wi_dim1 + 1;
    wi -= wi_offset;
    --zval;
    acol -= 8;
    --dmzo;
    df_dim1 = *ncomp;
    df_offset = df_dim1 + 1;
    df -= df_offset;

     
    if (*jj > 1) {
	goto L30;
    }
    i__1 = *kd;
    for (id = 1; id <= i__1; ++id) {
	wi[id + id * wi_dim1] = 1.;
 
    }

 

L30:
    fact = 1.;
    i__1 = (colord_._6) .mmax;
    for (l = 1; l <= i__1; ++l) {
	fact = fact * *hrho / (doublereal) l;
	basm[l - 1] = fact;
	i__2 = (colord_._6) .k;
	for (j = 1; j <= i__2; ++j) {
	    ha[j + l * 7 - 8] = fact * acol[j + l * 7];
 
	}
    }

 

    i__2 = (colord_._6) .mstar;
    for (jcol = 1; jcol <= i__2; ++jcol) {
	i__1 = *ncomp;
	for (ir = 1; ir <= i__1; ++ir) {
 
	    df[ir + jcol * df_dim1] = 0.;
	}
    }

 
 
 
 
 
 

    (*dfsub)(xcol, &zval[1], &df[df_offset]);
    if (iercol_ .iero > 0) {
	return 0;
    }
    i0 = (*jj - 1) * *ncomp;
    i1 = i0 + 1;
    i2 = i0 + *ncomp;

 

    if (colnln_ .nonlin == 0 || colnln_ .iter > 0) {
	goto L60;
    }
    i__1 = (colord_._6) .mstar;
    for (j = 1; j <= i__1; ++j) {
	fact = -zval[j];
	i__2 = *ncomp;
	for (id = 1; id <= i__2; ++id) {
	    dmzo[i0 + id] += fact * df[id + j * df_dim1];
 
	}
    }

 
 

L60:
    i__2 = (colord_._6) .mstar;
    for (j = 1; j <= i__2; ++j) {
	i__1 = *ncomp;
	for (id = 1; id <= i__1; ++id) {
	    vi[i0 + id + j * vi_dim1] = df[id + j * df_dim1];
 
	}
    }
    jn = 1;
    i__1 = *ncomp;
    for (jcomp = 1; jcomp <= i__1; ++jcomp) {
	mj = (colord_._6) .m[jcomp - 1];
	jn += mj;
	i__2 = mj;
	for (l = 1; l <= i__2; ++l) {
	    jv = jn - l;
	    jw = jcomp;
	    i__3 = (colord_._6) .k;
	    for (j = 1; j <= i__3; ++j) {
		ajl = -ha[j + l * 7 - 8];
		i__4 = i2;
		for (iw = i1; iw <= i__4; ++iw) {
		    wi[iw + jw * wi_dim1] += ajl * vi[iw + jv * vi_dim1];
 
		}
 
		jw += *ncomp;
	    }
	    lp1 = l + 1;
	    if (l == mj) {
		goto L130;
	    }
	    i__3 = mj;
	    for (ll = lp1; ll <= i__3; ++ll) {
		jdf = jn - ll;
		bl = basm[ll - l - 1];
		i__4 = i2;
		for (iw = i1; iw <= i__4; ++iw) {
		    vi[iw + jv * vi_dim1] += bl * vi[iw + jdf * vi_dim1];
 
		}
 
	    }
L130:
	    ;
	}
 
    }
    if (*jj < (colord_._6) .k) {
	return 0;
    }

 


 

    *msing = 0;
    dgefa_(&wi[wi_offset], kd, kd, &ipvtw[1], msing);

 

    if (*msing != 0) {
	return 0;
    }
    i__1 = (colord_._6) .mstar;
    for (j = 1; j <= i__1; ++j) {
	dgesl_(&wi[wi_offset], kd, kd, &ipvtw[1], &vi[j * vi_dim1 + 1], &c__0)
		;
 
    }
    return 0;
}  

  int gblock_(h__, gi, nrow, irow, wi, vi, kd, rhsz, rhsdmz, 
	ipvtw, mode)
doublereal *h__, *gi;
integer *nrow, *irow;
doublereal *wi, *vi;
integer *kd;
doublereal *rhsz, *rhsdmz;
integer *ipvtw, *mode;
{
     
    integer gi_dim1, gi_offset, vi_dim1, vi_offset, i__1, i__2, i__3, i__4;

     
    static doublereal fact, basm[5];
    static integer jcol;
    static doublereal rsum;
    static integer j, l;
    extern   int dgesl_();
    static integer icomp, jcomp;
    static doublereal hb[28]	 ;
    static integer id, jd, mj, ll, ir, ind;
    gi_dim1 = *nrow;
    gi_offset = gi_dim1 + 1;
    gi -= gi_offset;
    --wi;
    vi_dim1 = *kd;
    vi_offset = vi_dim1 + 1;
    vi -= vi_offset;
    --rhsz;
    --rhsdmz;
    --ipvtw;

     
    fact = 1.;
    basm[0] = 1.;
    i__1 = (colord_._7) .mmax;
    for (l = 1; l <= i__1; ++l) {
	fact = fact * *h__ / (doublereal) l;
	basm[l] = fact;
	i__2 = (colord_._7) .k;
	for (j = 1; j <= i__2; ++j) {
 
	    hb[j + l * 7 - 8] = fact * colbas_ .b[j + l * 7 - 8];
	}
 
    }

 

    switch ((int)*mode) {
	case 1:  goto L40;
	case 2:  goto L110;
    }

 

L40:
    i__1 = (colord_._7) .mstar;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (colord_._7) .mstar;
	for (ir = 1; ir <= i__2; ++ir) {
	    gi[*irow - 1 + ir + j * gi_dim1] = 0.;
 
	    gi[*irow - 1 + ir + ((colord_._7) .mstar + j) * gi_dim1] = 0.;
	}
 
	gi[*irow - 1 + j + ((colord_._7) .mstar + j) * gi_dim1] = 1.;
    }

 

    ir = *irow;
    i__1 = (colord_._7) .ncomp;
    for (icomp = 1; icomp <= i__1; ++icomp) {
	mj = (colord_._7) .m[icomp - 1];
	ir += mj;
	i__2 = mj;
	for (l = 1; l <= i__2; ++l) {
	    id = ir - l;
	    i__3 = (colord_._7) .mstar;
	    for (jcol = 1; jcol <= i__3; ++jcol) {
		ind = icomp;
		rsum = 0.;
		i__4 = (colord_._7) .k;
		for (j = 1; j <= i__4; ++j) {
		    rsum -= hb[j + l * 7 - 8] * vi[ind + jcol * vi_dim1];
 
		    ind += (colord_._7) .ncomp;
		}
		gi[id + jcol * gi_dim1] = rsum;
 
	    }
	    jd = id - *irow;
	    i__3 = l;
	    for (ll = 1; ll <= i__3; ++ll) {
		gi[id + (jd + ll) * gi_dim1] -= basm[ll - 1];
 
	    }
 
	}
 
    }
    return 0;

 

L110:
    dgesl_(&wi[1], kd, kd, &ipvtw[1], &rhsdmz[1], &c__0);
    ir = *irow;
    i__1 = (colord_._7) .ncomp;
    for (jcomp = 1; jcomp <= i__1; ++jcomp) {
	mj = (colord_._7) .m[jcomp - 1];
	ir += mj;
	i__2 = mj;
	for (l = 1; l <= i__2; ++l) {
	    ind = jcomp;
	    rsum = 0.;
	    i__3 = (colord_._7) .k;
	    for (j = 1; j <= i__3; ++j) {
		rsum += hb[j + l * 7 - 8] * rhsdmz[ind];
 
		ind += (colord_._7) .ncomp;
	    }
	    rhsz[ir - l] = rsum;
 
	}
 
    }
    return 0;
}  


 
 
 
 

  int appsln_(x, z__, fspace, ispace)
doublereal *x, *z__, *fspace;
integer *ispace;
{
    static doublereal a[28];
    static integer i__;
    static doublereal dummy[1];
    extern   int approx_();
    static integer is4, is5, is6;
    --ispace;
    --fspace;
    --z__;

     
    is6 = ispace[6];
    is5 = ispace[1] + 2;
    is4 = is5 + ispace[4] * (ispace[1] + 1);
    i__ = 1;
    approx_(&i__, x, &z__[1], a, &fspace[is6], &fspace[1], &ispace[1], &
	    fspace[is5], &fspace[is4], &ispace[2], &ispace[3], &ispace[5], &
	    ispace[8], &ispace[4], &c__2, dummy, &c__0);
    return 0;
}  

  int approx_(i__, x, zval, a, coef, xi, n, z__, dmz, k, ncomp,
	 mmax, m, mstar, mode, dmval, modm)
integer *i__;
doublereal *x, *zval, *a, *coef, *xi;
integer *n;
doublereal *z__, *dmz;
integer *k, *ncomp, *mmax, *m, *mstar, *mode;
doublereal *dmval;
integer *modm;
{
     
    static char fmt_900[] = "(\002 ****** DOMAIN ERROR IN APPROX ******\002/\002 X =\002,d20.10,\002   ALEFT =\002,d20.10,\002   ARIGHT =\002,d20.10)";

     
    integer i__1, i__2, i__3;

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static doublereal fact;
    static integer idmz;
    static doublereal zsum;
    static integer j, l;
    static doublereal s;
    extern   int rkbas_();
    static integer ileft, jcomp, lb;
    static doublereal bm[4], dm[7];
    static integer mj, ll, ir, iz, iright, ind;

     
    static cilist io___920 = { 0, 0, 0, fmt_900, 0 };
    --dmval;
    --m;
    --dmz;
    --z__;
    --xi;
    --coef;
    a -= 8;
    --zval;

     
    switch ((int)*mode) {
	case 1:  goto L10;
	case 2:  goto L30;
	case 3:  goto L80;
	case 4:  goto L90;
    }

 

L10:
    *x = xi[*i__];
    iz = (*i__ - 1) * *mstar;
    i__1 = *mstar;
    for (j = 1; j <= i__1; ++j) {
	++iz;
	zval[j] = z__[iz];
 
    }
    return 0;

 

L30:
    if (*x >= xi[1] - colout_ .precis && *x <= xi[*n + 1] + colout_ .precis) {
	goto L40;
    }
    if (colout_ .iprint < 1) {
	io___920.ciunit = colout_ .iout;
	s_wsfe(&io___920);
	do_fio(&c__1, (char *)&(*x), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&xi[1], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&xi[*n + 1], (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*x < xi[1]) {
	*x = xi[1];
    }
    if (*x > xi[*n + 1]) {
	*x = xi[*n + 1];
    }
L40:
    if (*i__ > *n || *i__ < 1) {
	*i__ = (*n + 1) / 2;
    }
    ileft = *i__;
    if (*x < xi[ileft]) {
	goto L60;
    }
    i__1 = *n;
    for (l = ileft; l <= i__1; ++l) {
	*i__ = l;
	if (*x < xi[l + 1]) {
	    goto L80;
	}
 
    }
    goto L80;
L60:
    iright = ileft - 1;
    i__1 = iright;
    for (l = 1; l <= i__1; ++l) {
	*i__ = iright + 1 - l;
	if (*x >= xi[*i__]) {
	    goto L80;
	}
 
    }

 

L80:
    s = (*x - xi[*i__]) / (xi[*i__ + 1] - xi[*i__]);
    rkbas_(&s, &coef[1], k, mmax, &a[8], dm, modm);

 

L90:
    bm[0] = *x - xi[*i__];
    i__1 = *mmax;
    for (l = 2; l <= i__1; ++l) {
	bm[l - 1] = bm[0] / (doublereal) l;
 
    }

 

 
    ir = 1;
    iz = (*i__ - 1) * *mstar + 1;
    idmz = (*i__ - 1) * *k * *ncomp;
    i__1 = *ncomp;
    for (jcomp = 1; jcomp <= i__1; ++jcomp) {
	mj = m[jcomp];
	ir += mj;
	iz += mj;
	i__2 = mj;
	for (l = 1; l <= i__2; ++l) {
	    ind = idmz + jcomp;
	    zsum = 0.;
	    i__3 = *k;
	    for (j = 1; j <= i__3; ++j) {
		zsum += a[j + l * 7] * dmz[ind];
 
		ind += *ncomp;
	    }
	    i__3 = l;
	    for (ll = 1; ll <= i__3; ++ll) {
		lb = l + 1 - ll;
 
		zsum = zsum * bm[lb - 1] + z__[iz - ll];
	    }
 
	    zval[ir - l] = zsum;
	}
 
    }
    if (*modm == 0) {
	return 0;
    }

 

    i__1 = *ncomp;
    for (jcomp = 1; jcomp <= i__1; ++jcomp) {
 
	dmval[jcomp] = 0.;
    }
    ++idmz;
    i__1 = *k;
    for (j = 1; j <= i__1; ++j) {
	fact = dm[j - 1];
	i__2 = *ncomp;
	for (jcomp = 1; jcomp <= i__2; ++jcomp) {
	    dmval[jcomp] += fact * dmz[idmz];
	    ++idmz;
 
	}
 
    }
    return 0;
 
}  

  int rkbas_(s, coef, k, m, rkb, dm, mode)
doublereal *s, *coef;
integer *k, *m;
doublereal *rkb, *dm;
integer *mode;
{
     
    integer coef_dim1, coef_offset, i__1, i__2, i__3;

     
    static integer i__, j, l;
    static doublereal p, t[10];
    static integer lb, kpm1;
     
    coef_dim1 = *k;
    coef_offset = coef_dim1 + 1;
    coef -= coef_offset;
    rkb -= 8;
    --dm;

     
    if (*k == 1) {
	goto L70;
    }
    kpm1 = *k + *m - 1;
    i__1 = kpm1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	t[i__ - 1] = *s / (doublereal) i__;
    }
    i__1 = *m;
    for (l = 1; l <= i__1; ++l) {
	lb = *k + l + 1;
	i__2 = *k;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    p = coef[i__ * coef_dim1 + 1];
	    i__3 = *k;
	    for (j = 2; j <= i__3; ++j) {
		p = p * t[lb - j - 1] + coef[j + i__ * coef_dim1];
 
	    }
	    rkb[i__ + l * 7] = p;
 
	}
 
    }
    if (*mode == 0) {
	return 0;
    }
    i__1 = *k;
    for (i__ = 1; i__ <= i__1; ++i__) {
	p = coef[i__ * coef_dim1 + 1];
	i__2 = *k;
	for (j = 2; j <= i__2; ++j) {
 
	    p = p * t[*k + 1 - j - 1] + coef[j + i__ * coef_dim1];
	}
	dm[i__] = p;
 
    }
    return 0;
L70:
    rkb[8] = 1.;
    dm[1] = 1.;
    return 0;
}  

  int vmonde_(rho, coef, k)
doublereal *rho, *coef;
integer *k;
{
     
    integer i__1, i__2;

     
    static integer ifac, i__, j, km1, kmi;


 


 
 
 

 



     
    --coef;
    --rho;

     
    if (*k == 1) {
	return 0;
    }
    km1 = *k - 1;
    i__1 = km1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	kmi = *k - i__;
	i__2 = kmi;
	for (j = 1; j <= i__2; ++j) {
	    coef[j] = (coef[j + 1] - coef[j]) / (rho[j + i__] - rho[j]);
 
	}
    }

    ifac = 1;
    i__2 = km1;
    for (i__ = 1; i__ <= i__2; ++i__) {
	kmi = *k + 1 - i__;
	i__1 = kmi;
	for (j = 2; j <= i__1; ++j) {
 
	    coef[j] -= rho[j + i__ - 1] * coef[j - 1];
	}
	coef[kmi] = (doublereal) ifac * coef[kmi];
	ifac *= i__;
 
    }
    coef[1] = (doublereal) ifac * coef[1];
    return 0;
}  

  int horder_(i__, uhigh, hi, dmz, ncomp, k)
integer *i__;
doublereal *uhigh, *hi, *dmz;
integer *ncomp, *k;
{
     
    integer i__1, i__2;

     
    double pow_di();

     
    static doublereal fact;
    static integer idmz, j, id;
    static doublereal dn;
    static integer kin;


 


 
 
 

 
 
 
 
 
 
 
 
 

 


 


     
    --dmz;
    --uhigh;

     
    i__1 = *k - 1;
    dn = 1. / pow_di(hi, &i__1);

 

    i__1 = *ncomp;
    for (id = 1; id <= i__1; ++id) {
	uhigh[id] = 0.;
 
    }
    kin = 1;
    idmz = (*i__ - 1) * *k * *ncomp + 1;
    i__1 = *k;
    for (j = 1; j <= i__1; ++j) {
	fact = dn * colloc_ .coef[kin - 1];
	i__2 = *ncomp;
	for (id = 1; id <= i__2; ++id) {
	    uhigh[id] += fact * dmz[idmz];
	    ++idmz;
 
	}
	kin += *k;
 
    }
    return 0;
}  

  int dmzsol_(kd, mstar, n, v, z__, dmz)
integer *kd, *mstar, *n;
doublereal *v, *z__, *dmz;
{
     
    integer v_dim1, v_offset, dmz_dim1, dmz_offset, i__1, i__2, i__3;

     
    static doublereal fact;
    static integer i__, j, l, jz;


 


 
 
 

 


 

     
    dmz_dim1 = *kd;
    dmz_offset = dmz_dim1 + 1;
    dmz -= dmz_offset;
    v_dim1 = *kd;
    v_offset = v_dim1 + 1;
    v -= v_offset;
    --z__;

     
    jz = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *mstar;
	for (j = 1; j <= i__2; ++j) {
	    fact = z__[jz];
	    i__3 = *kd;
	    for (l = 1; l <= i__3; ++l) {
		dmz[l + i__ * dmz_dim1] += fact * v[l + jz * v_dim1];
 
	    }
	    ++jz;
 
	}
 
    }
    return 0;
}  

 
 
 
 
 
 
 

  int fcblok_(bloks, integs, nbloks, ipivot, scrtch, info)
doublereal *bloks;
integer *integs, *nbloks, *ipivot;
doublereal *scrtch;
integer *info;
{
    static integer ncol, last, nrow, i__, index;
    extern   int factrb_(), shiftb_();
    static integer indexn, indexx;



 

 
 
 

 
 
 

 

 
 

 
 
 
 
 
 
 
 
 
 
 
 
 

 


     
    --bloks;
    integs -= 4;
    --ipivot;
    --scrtch;

     
    *info = 0;
    indexx = 1;
    indexn = 1;
    i__ = 1;

 

L10:
    index = indexn;
    nrow = integs[i__ * 3 + 1];
    ncol = integs[i__ * 3 + 2];
    last = integs[i__ * 3 + 3];

 
 

    factrb_(&bloks[index], &ipivot[indexx], &scrtch[1], &nrow, &ncol, &last, 
	    info);

 


    if (*info != 0) {
	goto L20;
    }
    if (i__ == *nbloks) {
	return 0;
    }
    ++i__;
    indexn = nrow * ncol + index;
    indexx += last;

 

    shiftb_(&bloks[index], &nrow, &ncol, &last, &bloks[indexn], &integs[i__ * 
	    3 + 1], &integs[i__ * 3 + 2]);
    goto L10;
L20:
    *info = *info + indexx - 1;
    return 0;
}  

  int factrb_(w, ipivot, d__, nrow, ncol, last, info)
doublereal *w;
integer *ipivot;
doublereal *d__;
integer *nrow, *ncol, *last, *info;
{
     
    integer w_dim1, w_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    static integer i__, j, k, l;
    static doublereal s, t, colmax;
    static integer kp1;
     
    --d__;
    --ipivot;
    w_dim1 = *nrow;
    w_offset = w_dim1 + 1;
    w -= w_offset;

     
    i__1 = *nrow;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__[i__] = 0.;
 
    }
    i__1 = *ncol;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *nrow;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    d__2 = d__[i__], d__3 = (d__1 = w[i__ + j * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    d__[i__] = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	}
    }

 
 

    k = 1;

 
 
 
 
 

L30:
    if (d__[k] == 0.) {
	goto L90;
    }
    if (k == *nrow) {
	goto L80;
    }
    l = k;
    kp1 = k + 1;
    colmax = (d__1 = w[k + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / d__[k];

 

    i__2 = *nrow;
    for (i__ = kp1; i__ <= i__2; ++i__) {
	if ((d__1 = w[i__ + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= colmax * d__[i__]) {
	    goto L40;
	}
	colmax = (d__1 = w[i__ + k * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / d__[i__];
	l = i__;
L40:
	;
    }
    ipivot[k] = l;
    t = w[l + k * w_dim1];
    s = d__[l];
    if (l == k) {
	goto L50;
    }
    w[l + k * w_dim1] = w[k + k * w_dim1];
    w[k + k * w_dim1] = t;
    d__[l] = d__[k];
    d__[k] = s;
L50:

 
 

    if ((( t ) >= 0 ? ( t ) : -( t ))  + d__[k] <= d__[k]) {
	goto L90;
    }

 
 
 
 

    t = -1. / t;
    i__2 = *nrow;
    for (i__ = kp1; i__ <= i__2; ++i__) {
 
	w[i__ + k * w_dim1] *= t;
    }
    i__2 = *ncol;
    for (j = kp1; j <= i__2; ++j) {
	t = w[l + j * w_dim1];
	if (l == k) {
	    goto L62;
	}
	w[l + j * w_dim1] = w[k + j * w_dim1];
	w[k + j * w_dim1] = t;
L62:
	if (t == 0.) {
	    goto L70;
	}
	i__1 = *nrow;
	for (i__ = kp1; i__ <= i__1; ++i__) {
 
	    w[i__ + j * w_dim1] += w[i__ + k * w_dim1] * t;
	}
L70:
	;
    }
    k = kp1;

 

    if (k <= *last) {
	goto L30;
    }
    return 0;

 
 

L80:
    if ((d__1 = w[*nrow + *nrow * w_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + d__[*nrow] > d__[*
	    nrow]) {
	return 0;
    }

 

L90:
    *info = k;
    return 0;
}  

  int shiftb_(ai, nrowi, ncoli, last, ai1, nrowi1, ncoli1)
doublereal *ai;
integer *nrowi, *ncoli, *last;
doublereal *ai1;
integer *nrowi1, *ncoli1;
{
     
    integer ai_dim1, ai_offset, ai1_dim1, ai1_offset, i__1, i__2;

     
    static integer jmax, mmax, j, m, jmaxp1;


 


 
 
 
 
 

 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 


     
    ai_dim1 = *nrowi;
    ai_offset = ai_dim1 + 1;
    ai -= ai_offset;
    ai1_dim1 = *nrowi1;
    ai1_offset = ai1_dim1 + 1;
    ai1 -= ai1_offset;

     
    mmax = *nrowi - *last;
    jmax = *ncoli - *last;
    if (mmax < 1 || jmax < 1) {
	return 0;
    }

 

    i__1 = jmax;
    for (j = 1; j <= i__1; ++j) {
	i__2 = mmax;
	for (m = 1; m <= i__2; ++m) {
 
	    ai1[m + j * ai1_dim1] = ai[*last + m + (*last + j) * ai_dim1];
	}
    }
    if (jmax == *ncoli1) {
	return 0;
    }

 

    jmaxp1 = jmax + 1;
    i__2 = *ncoli1;
    for (j = jmaxp1; j <= i__2; ++j) {
	i__1 = mmax;
	for (m = 1; m <= i__1; ++m) {
 
	    ai1[m + j * ai1_dim1] = 0.;
	}
    }
    return 0;
}  

  int sbblok_(bloks, integs, nbloks, ipivot, x)
doublereal *bloks;
integer *integs, *nbloks, *ipivot;
doublereal *x;
{
     
    integer i__1;

     
    static integer ncol, last, nrow, i__, j, index;
    extern   int subbak_();
    static integer indexx;
    extern   int subfor_();
    static integer nbp1;


 


 

 

 
 
 

 
 
 
 

 



 

     
    --bloks;
    integs -= 4;
    --ipivot;
    --x;

     
    index = 1;
    indexx = 1;
    i__1 = *nbloks;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nrow = integs[i__ * 3 + 1];
	last = integs[i__ * 3 + 3];
	subfor_(&bloks[index], &ipivot[indexx], &nrow, &last, &x[indexx]);
	index = nrow * integs[i__ * 3 + 2] + index;
 
	indexx += last;
    }

 

    nbp1 = *nbloks + 1;
    i__1 = *nbloks;
    for (j = 1; j <= i__1; ++j) {
	i__ = nbp1 - j;
	nrow = integs[i__ * 3 + 1];
	ncol = integs[i__ * 3 + 2];
	last = integs[i__ * 3 + 3];
	index -= nrow * ncol;
	indexx -= last;
 
	subbak_(&bloks[index], &nrow, &ncol, &last, &x[indexx]);
    }
    return 0;
}  

  int subfor_(w, ipivot, nrow, last, x)
doublereal *w;
integer *ipivot, *nrow, *last;
doublereal *x;
{
     
    integer w_dim1, w_offset, i__1, i__2;

     
    static integer i__, k;
    static doublereal t;
    static integer lstep, ip, kp1;


 


 
 
 

 
 
 
 
 
 
 

 



     
    --x;
    --ipivot;
    w_dim1 = *nrow;
    w_offset = w_dim1 + 1;
    w -= w_offset;

     
    if (*nrow == 1) {
	return 0;
    }
 
    i__1 = *nrow - 1;
    lstep = (( i__1 ) <= ( *last ) ? ( i__1 ) : ( *last )) ;
    i__1 = lstep;
    for (k = 1; k <= i__1; ++k) {
	kp1 = k + 1;
	ip = ipivot[k];
	t = x[ip];
	x[ip] = x[k];
	x[k] = t;
	if (t == 0.) {
	    goto L20;
	}
	i__2 = *nrow;
	for (i__ = kp1; i__ <= i__2; ++i__) {
 
	    x[i__] += w[i__ + k * w_dim1] * t;
	}
L20:
	;
    }
 
    return 0;
}  

  int subbak_(w, nrow, ncol, last, x)
doublereal *w;
integer *nrow, *ncol, *last;
doublereal *x;
{
     
    integer w_dim1, w_offset, i__1, i__2;

     
    static integer i__, j, k;
    static doublereal t;
    static integer kb, km1, lm1, lp1;


 


 

 
 
 
 

 
 

 
 
 
 
 

 



     
    --x;
    w_dim1 = *nrow;
    w_offset = w_dim1 + 1;
    w -= w_offset;

     
    lp1 = *last + 1;
    if (lp1 > *ncol) {
	goto L30;
    }
    i__1 = *ncol;
    for (j = lp1; j <= i__1; ++j) {
	t = -x[j];
	if (t == 0.) {
	    goto L20;
	}
	i__2 = *last;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    x[i__] += w[i__ + j * w_dim1] * t;
	}
L20:
	;
    }
L30:
    if (*last == 1) {
	goto L60;
    }
    lm1 = *last - 1;
    i__1 = lm1;
    for (kb = 1; kb <= i__1; ++kb) {
	km1 = *last - kb;
	k = km1 + 1;
	x[k] /= w[k + k * w_dim1];
	t = -x[k];
	if (t == 0.) {
	    goto L50;
	}
	i__2 = km1;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    x[i__] += w[i__ + k * w_dim1] * t;
	}
L50:
	;
    }
L60:
    x[1] /= w[w_dim1 + 1];
    return 0;
}  

  int ddaini_(x, y, yprime, neq, res, jac, h__, wt, idid, rpar,
	 ipar, phi, delta, e, wm, iwm, hmin, uround, nonneg, ntemp)
doublereal *x, *y, *yprime;
integer *neq;
  int (*res) (), (*jac) ();
doublereal *h__, *wt;
integer *idid;
doublereal *rpar;
integer *ipar;
doublereal *phi, *delta, *e, *wm;
integer *iwm;
doublereal *hmin, *uround;
integer *nonneg, *ntemp;
{
     

    static integer maxit = 10;
    static integer mjac = 5;
    static doublereal damp = .75;

     
    integer phi_dim1, phi_offset, i__1;
    doublereal d__1, d__2;

     
    double pow_dd();

     
    static doublereal rate;
    static integer ires;
    static doublereal xold;
    static integer i__, jcalc, m;
    static doublereal r__, s, ynorm;
    extern   int ddajac_();
    static doublereal cj;
    extern doublereal ddanrm_();
    extern   int ddaslv_();
    static logical convgd;
    static doublereal delnrm, oldnrm;
    static integer ncf, nef, ier, nsf;
    static doublereal err;
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = phi_dim1 + 1;
    phi -= phi_offset;
    --wt;
    --rpar;
    --ipar;
    --delta;
    --e;
    --wm;
    --iwm;

     


 
 
 
 

 
    *idid = 1;
    nef = 0;
    ncf = 0;
    nsf = 0;
    xold = *x;
    ynorm = ddanrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]);

 
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	phi[i__ + phi_dim1] = y[i__];
 
	phi[i__ + (phi_dim1 << 1)] = yprime[i__];
    }


 
 
 
 

 
L200:
    cj = 1. / *h__;
    *x += *h__;

 
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] += *h__ * yprime[i__];
    }

    jcalc = -1;
    m = 0;
    convgd = (1) ;


 
L300:
    ++iwm[12];
    ires = 0;

    (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ierode_ .iero != 0) {
	return 0;
    }
    if (ires < 0) {
	goto L430;
    }


 
    if (jcalc != -1) {
	goto L310;
    }
    ++iwm[13];
    jcalc = 0;
    ddajac_(neq, x, &y[1], &yprime[1], &delta[1], &cj, h__, &ier, &wt[1], &e[
	    1], &wm[1], &iwm[1], res, &ires, uround, jac, &rpar[1], &ipar[1], 
	    ntemp);
    if (ierode_ .iero != 0) {
	return 0;
    }

    s = 1e6;
    if (ires < 0) {
	goto L430;
    }
    if (ier != 0) {
	goto L430;
    }
    nsf = 0;



 
L310:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	delta[i__] *= damp;
    }

 
 

    ddaslv_(neq, &delta[1], &wm[1], &iwm[1]);

 
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] -= delta[i__];
 
	yprime[i__] -= cj * delta[i__];
    }

 

    delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm <= *uround * 100. * ynorm) {
	goto L400;
    }

    if (m > 0) {
	goto L340;
    }
    oldnrm = delnrm;
    goto L350;

L340:
    d__1 = delnrm / oldnrm;
    d__2 = 1. / m;
    rate = pow_dd(&d__1, &d__2);
    if (rate > .9) {
	goto L430;
    }
    s = rate / (1. - rate);

L350:
    if (s * delnrm <= .33) {
	goto L400;
    }


 
 
 
 
 

    ++m;
    if (m >= maxit) {
	goto L430;
    }

    if (m / mjac * mjac == m) {
	jcalc = -1;
    }
    goto L300;


 
 
L400:
    if (*nonneg == 0) {
	goto L450;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = y[i__];
	delta[i__] = (( d__1 ) <= ( 0. ) ? ( d__1 ) : ( 0. )) ;
    }

    delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm > .33) {
	goto L430;
    }

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] -= delta[i__];
 
	yprime[i__] -= cj * delta[i__];
    }
    goto L450;


 
L430:
    convgd = (0) ;
L450:
    if (! convgd) {
	goto L600;
    }



 
 
 
 
 

    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	e[i__] = y[i__] - phi[i__ + phi_dim1];
    }
    err = ddanrm_(neq, &e[1], &wt[1], &rpar[1], &ipar[1]);

    if (err <= 1.) {
	return 0;
    }



 
 
 
 
 
 
 

L600:
    *x = xold;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] = phi[i__ + phi_dim1];
 
	yprime[i__] = phi[i__ + (phi_dim1 << 1)];
    }

    if (convgd) {
	goto L640;
    }
    if (ier == 0) {
	goto L620;
    }
    ++nsf;
    *h__ *= .25;
    if (nsf < 3 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -12;
    return 0;
L620:
    if (ires > -2) {
	goto L630;
    }
    *idid = -12;
    return 0;
L630:
    ++ncf;
    *h__ *= .25;
    if (ncf < 10 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -12;
    return 0;

L640:
    ++nef;
    r__ = .9 / (err * 2. + 1e-4);
 
    d__1 = .1, d__2 = (( .5 ) <= ( r__ ) ? ( .5 ) : ( r__ )) ;
    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    *h__ *= r__;
    if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin && nef < 10) {
	goto L690;
    }
    *idid = -12;
    return 0;
L690:
    goto L200;

 
}  

  int ddajac_(neq, x, y, yprime, delta, cj, h__, ier, wt, e, 
	wm, iwm, res, ires, uround, jac, rpar, ipar, ntemp)
integer *neq;
doublereal *x, *y, *yprime, *delta, *cj, *h__;
integer *ier;
doublereal *wt, *e, *wm;
integer *iwm;
  int (*res) ();
integer *ires;
doublereal *uround;
  int (*jac) ();
doublereal *rpar;
integer *ipar, *ntemp;
{
     
    integer i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4, d__5;

     
    double sqrt(), d_sign();

     
    static integer nrow;
    static doublereal squr;
    static integer npdm1;
    extern   int dgbfa_(), dgefa_();
    static integer i__, j, k, l, n, mband, lenpd, isave, msave;
    static doublereal ysave;
    static integer i1, i2, mtype, ii, meband;
    static doublereal delinv;
    static integer ipsave;
    static doublereal ypsave;
    static integer mba;
    static doublereal del;
    static integer meb1;
     
    --ipar;
    --rpar;
    --iwm;
    --wm;
    --e;
    --wt;
    --delta;
    --yprime;
    --y;

     
    *ier = 0;
    npdm1 = 0;
    mtype = iwm[4];
    switch ((int)mtype) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L500;
    }


 
L100:
    lenpd = *neq * *neq;
    i__1 = lenpd;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[npdm1 + i__] = 0.;
    }
    (*jac)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]);
    if (ierode_ .iero != 0) {
	return 0;
    }
    goto L230;


 
L200:
    *ires = 0;
    nrow = npdm1;
    squr = sqrt(*uround);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	d__4 = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[i__], 
		(( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[i__], 
		(( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) );
	del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ;
	d__1 = *h__ * yprime[i__];
	del = d_sign(&del, &d__1);
	del = y[i__] + del - y[i__];
	ysave = y[i__];
	ypsave = yprime[i__];
	y[i__] += del;
	yprime[i__] += *cj * del;
	(*res)(x, &y[1], &yprime[1], &e[1], ires, &rpar[1], &ipar[1]);
	if (ierode_ .iero != 0) {
	    return 0;
	}
	if (*ires < 0) {
	    return 0;
	}
	delinv = 1. / del;
	i__2 = *neq;
	for (l = 1; l <= i__2; ++l) {
 
	    wm[nrow + l] = (e[l] - delta[l]) * delinv;
	}
	nrow += *neq;
	y[i__] = ysave;
	yprime[i__] = ypsave;
 
    }


 
L230:
    dgefa_(&wm[1], neq, neq, &iwm[21], ier);
    return 0;


 
L300:
    return 0;


 
L400:
    lenpd = ((iwm[1] << 1) + iwm[2] + 1) * *neq;
    i__1 = lenpd;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[npdm1 + i__] = 0.;
    }
    (*jac)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]);
    if (ierode_ .iero != 0) {
	return 0;
    }
    meband = (iwm[1] << 1) + iwm[2] + 1;
    goto L550;


 
L500:
    mband = iwm[1] + iwm[2] + 1;
    mba = (( mband ) <= ( *neq ) ? ( mband ) : ( *neq )) ;
    meband = mband + iwm[1];
    meb1 = meband - 1;
    msave = *neq / mband + 1;
    isave = *ntemp - 1;
    ipsave = isave + msave;
    *ires = 0;
    squr = sqrt(*uround);
    i__1 = mba;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *neq;
	i__3 = mband;
	for (n = j; i__3 < 0 ? n >= i__2 : n <= i__2; n += i__3) {
	    k = (n - j) / mband + 1;
	    wm[isave + k] = y[n];
	    wm[ipsave + k] = yprime[n];
 
	    d__4 = (d__1 = y[n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[n], 
		    (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[n], 
		    (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) );
	    del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ;
	    d__1 = *h__ * yprime[n];
	    del = d_sign(&del, &d__1);
	    del = y[n] + del - y[n];
	    y[n] += del;
 
	    yprime[n] += *cj * del;
	}
	(*res)(x, &y[1], &yprime[1], &e[1], ires, &rpar[1], &ipar[1]);
	if (ierode_ .iero != 0) {
	    return 0;
	}
	if (*ires < 0) {
	    return 0;
	}
	i__3 = *neq;
	i__2 = mband;
	for (n = j; i__2 < 0 ? n >= i__3 : n <= i__3; n += i__2) {
	    k = (n - j) / mband + 1;
	    y[n] = wm[isave + k];
	    yprime[n] = wm[ipsave + k];
 
	    d__4 = (d__1 = y[n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__5 = (d__2 = *h__ * yprime[n], 
		    (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ), d__4 = (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) , d__5 = (d__3 = wt[n], 
		    (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) );
	    del = squr * (( d__4 ) >= ( d__5 ) ? ( d__4 ) : ( d__5 )) ;
	    d__1 = *h__ * yprime[n];
	    del = d_sign(&del, &d__1);
	    del = y[n] + del - y[n];
	    delinv = 1. / del;
 
	    i__4 = 1, i__5 = n - iwm[2];
	    i1 = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;
 
	    i__4 = *neq, i__5 = n + iwm[1];
	    i2 = (( i__4 ) <= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;
	    ii = n * meb1 - iwm[1] + npdm1;
	    i__4 = i2;
	    for (i__ = i1; i__ <= i__4; ++i__) {
 
		wm[ii + i__] = (e[i__] - delta[i__]) * delinv;
	    }
 
	}
 
    }


 
L550:
    dgbfa_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[21], ier);
    return 0;
 
}  

doublereal ddanrm_(neq, v, wt, rpar, ipar)
integer *neq;
doublereal *v, *wt, *rpar;
integer *ipar;
{
     
    integer i__1;
    doublereal ret_val, d__1, d__2;

     
    double sqrt();

     
    static doublereal vmax;
    static integer i__;
    static doublereal sum;
    --wt;
    --v;
    --rpar;
    --ipar;

     
    ret_val = 0.;
    vmax = 0.;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = v[i__] / wt[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > vmax) {
	    vmax = (d__2 = v[i__] / wt[i__], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) );
	}
 
    }
    if (vmax <= 0.) {
	goto L30;
    }
    sum = 0.;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = v[i__] / wt[i__] / vmax;
	sum += d__1 * d__1;
    }
    ret_val = vmax * sqrt(sum / *neq);
L30:
    return ret_val;
 
}  

  int ddaslv_(neq, delta, wm, iwm)
integer *neq;
doublereal *delta, *wm;
integer *iwm;
{
    extern   int dgbsl_(), dgesl_();
    static integer mtype, meband;
    --iwm;
    --wm;
    --delta;

     
    mtype = iwm[4];
    switch ((int)mtype) {
	case 1:  goto L100;
	case 2:  goto L100;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L400;
    }

 
L100:
    dgesl_(&wm[1], neq, neq, &iwm[21], &delta[1], &c__0);
    return 0;

 
L300:
    return 0;

 
L400:
    meband = (iwm[1] << 1) + iwm[2] + 1;
    dgbsl_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[21], &delta[1], &c__0)
	    ;
    return 0;
 
}  

  int ddassl_(res, neq, t, y, yprime, tout, info, rtol, atol, 
	idid, rwork, lrw, iwork, liw, rpar, ipar, jac)
  int (*res) ();
integer *neq;
doublereal *t, *y, *yprime, *tout;
integer *info;
doublereal *rtol, *atol;
integer *idid;
doublereal *rwork;
integer *lrw, *iwork, *liw;
doublereal *rpar;
integer *ipar;
  int (*jac) ();
{
     
    address a__1[4], a__2[5], a__3[6], a__4[3], a__5[2];
    integer i__1, i__2[4], i__3[5], i__4[6], i__5[3], i__6[2];
    doublereal d__1, d__2;
    char ch__1[118], ch__2[81], ch__3[128], ch__4[62], ch__5[110], ch__6[121],
	     ch__7[90], ch__8[132], ch__9[126], ch__10[85], ch__11[98], 
	    ch__12[21], ch__13[30], ch__14[61], ch__15[71], ch__16[32], 
	    ch__17[51], ch__18[78], ch__19[66], ch__20[49], ch__21[27];

     
    integer s_wsfi(), do_fio(), e_wsfi();
      int s_cat();
    double d_sign();

     
    static logical done;
    static integer lphi;
    static doublereal hmax, hmin;
    static char xern1[8], xern2[8], xern3[16], xern4[16];
    static doublereal h__;
    static integer i__, mband;
    static doublereal r__;
    static integer lenpd;
    static doublereal atoli;
    static integer msave, itemp, leniw, nzflg, ntemp, lenrw;
    static doublereal tdist;
    static integer mxord;
    static doublereal rtoli, tnext, tstop;
    static integer le;
    extern doublereal dlamch_();
    extern   int ddaini_();
    static doublereal ho, rh, tn;
    extern doublereal ddanrm_();
    extern   int ddatrp_(), ddastp_(), ddawts_(), xermsg_();
    static doublereal uround, ypnorm;
    static integer lpd, lwm, lwt;

     
    static icilist io___1060 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1084 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1085 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1086 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1087 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1089 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1090 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1091 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1092 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1093 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1094 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1095 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1096 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1097 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1098 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1099 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1100 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1101 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1102 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1103 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1104 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1106 = { 0, xern2, 0, "(I8)", 8, 1 };
    static icilist io___1107 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1108 = { 0, xern2, 0, "(I8)", 8, 1 };
    static icilist io___1109 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1110 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1111 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1112 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1113 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1114 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1115 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1116 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1117 = { 0, xern4, 0, "(1P,D15.6)", 16, 1 };
    static icilist io___1118 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1119 = { 0, xern1, 0, "(I8)", 8, 1 };
    static icilist io___1120 = { 0, xern3, 0, "(1P,D15.6)", 16, 1 };
    --ipar;
    --rpar;
    --iwork;
    --rwork;
    --atol;
    --rtol;
    --info;
    --yprime;
    --y;

     
    if (info[1] != 0) {
	goto L100;
    }
    for (i__ = 2; i__ <= 11; ++i__) {
	if (info[i__] != 0 && info[i__] != 1) {
	    goto L701;
	}
 
    }

    if (*neq <= 0) {
	goto L702;
    }

 
    mxord = 5;
    if (info[9] == 0) {
	goto L20;
    }
    mxord = iwork[3];
    if (mxord < 1 || mxord > 5) {
	goto L703;
    }
L20:
    iwork[3] = mxord;

 
    if (info[6] != 0) {
	goto L40;
    }
 
    i__1 = *neq;
    lenpd = i__1 * i__1;
    lenrw = (iwork[3] + 4) * *neq + 40 + lenpd;
    if (info[5] != 0) {
	goto L30;
    }
    iwork[4] = 2;
    goto L60;
L30:
    iwork[4] = 1;
    goto L60;
L40:
    if (iwork[1] < 0 || iwork[1] >= *neq) {
	goto L717;
    }
    if (iwork[2] < 0 || iwork[2] >= *neq) {
	goto L718;
    }
    lenpd = ((iwork[1] << 1) + iwork[2] + 1) * *neq;
    if (info[5] != 0) {
	goto L50;
    }
    iwork[4] = 5;
    mband = iwork[1] + iwork[2] + 1;
    msave = *neq / mband + 1;
    lenrw = (iwork[3] + 4) * *neq + 40 + lenpd + (msave << 1);
    goto L60;
L50:
    iwork[4] = 4;
    lenrw = (iwork[3] + 4) * *neq + 40 + lenpd;

 
L60:
    leniw = *neq + 20;
    iwork[16] = lenpd;
    if (*lrw < lenrw) {
	goto L704;
    }
    if (*liw < leniw) {
	goto L705;
    }

 
    if (*tout == *t) {
	goto L719;
    }

 
    if (info[7] == 0) {
	goto L70;
    }
    hmax = rwork[2];
    if (hmax <= 0.) {
	goto L710;
    }
L70:

 
    iwork[11] = 0;
    iwork[12] = 0;
    iwork[13] = 0;

    iwork[10] = 0;
    *idid = 1;
    goto L200;

 

 
 
 
 
 


L100:
    if (info[1] == 1) {
	goto L110;
    }
    if (info[1] != -1) {
	goto L701;
    }

 
 
 
 
    s_wsfi(&io___1060);
    do_fio(&c__1, (char *)&(*idid), (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__2[0] = 57, a__1[0] = "THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ";
    i__2[1] = 8, a__1[1] = xern1;
    i__2[2] = 39, a__1[2] = " AND NO APPROPRIATE ACTION WAS TAKEN.  ";
    i__2[3] = 14, a__1[3] = "RUN TERMINATED";
    s_cat(ch__1, a__1, i__2, &c__4, 118L);
    xermsg_("SLATEC", "DDASSL", ch__1, &c_n998, &c__2, 6L, 6L, 118L);
    return 0;
L110:
    iwork[10] = iwork[11];

 

 
 
 
 
 


L200:
 
    nzflg = 0;
    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (info[2] == 1) {
	    rtoli = rtol[i__];
	}
	if (info[2] == 1) {
	    atoli = atol[i__];
	}
	if (rtoli > 0. || atoli > 0.) {
	    nzflg = 1;
	}
	if (rtoli < 0.) {
	    goto L706;
	}
	if (atoli < 0.) {
	    goto L707;
	}
 
    }
    if (nzflg == 0) {
	goto L708;
    }

 
 
    le = *neq + 41;
    lwt = le + *neq;
    lphi = lwt + *neq;
    lpd = lphi + (iwork[3] + 1) * *neq;
    lwm = lpd;
    ntemp = iwork[16] + 1;
    if (info[1] == 1) {
	goto L400;
    }

 

 
 
 
 
 


    tn = *t;
    *idid = 1;

 
    ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], &
	    ipar[1]);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[lwt + i__ - 1] <= 0.) {
	    goto L713;
	}
 
    }

 
    uround = dlamch_("P", 1L);
    rwork[9] = uround;
 
    d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    hmin = uround * 4. * (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;

 
    tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    if (tdist < hmin) {
	goto L714;
    }

 
    if (info[8] == 0) {
	goto L310;
    }
    ho = rwork[3];
    if ((*tout - *t) * ho < 0.) {
	goto L711;
    }
    if (ho == 0.) {
	goto L712;
    }
    goto L320;
L310:

 
 
    ho = tdist * .001;
    ypnorm = ddanrm_(neq, &yprime[1], &rwork[lwt], &rpar[1], &ipar[1]);
    if (ypnorm > .5 / ho) {
	ho = .5 / ypnorm;
    }
    d__1 = *tout - *t;
    ho = d_sign(&ho, &d__1);
 
L320:
    if (info[7] == 0) {
	goto L330;
    }
    rh = (( ho ) >= 0 ? ( ho ) : -( ho ))  / rwork[2];
    if (rh > 1.) {
	ho /= rh;
    }
 
L330:
    if (info[4] == 0) {
	goto L340;
    }
    tstop = rwork[1];
    if ((tstop - *t) * ho < 0.) {
	goto L715;
    }
    if ((*t + ho - tstop) * ho > 0.) {
	ho = tstop - *t;
    }
    if ((tstop - *tout) * ho < 0.) {
	goto L709;
    }

 
L340:
    if (info[11] == 0) {
	goto L350;
    }
    ddaini_(&tn, &y[1], &yprime[1], neq, res, jac, &ho, &rwork[lwt], idid, &
	    rpar[1], &ipar[1], &rwork[lphi], &rwork[41], &rwork[le], &rwork[
	    lwm], &iwork[1], &hmin, &rwork[9], &info[10], &ntemp);
    if (ierode_ .iero != 0) {
	return 0;
    }
    if (*idid < 0) {
	goto L390;
    }

 
L350:
    h__ = ho;
    rwork[3] = h__;

 
    itemp = lphi + *neq;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	rwork[lphi + i__ - 1] = y[i__];
 
	rwork[itemp + i__ - 1] = h__ * yprime[i__];
    }

L390:
    goto L500;

 
 
 
 
 
 

L400:
    uround = rwork[9];
    done = (0) ;
    tn = rwork[4];
    h__ = rwork[3];
    if (info[7] == 0) {
	goto L410;
    }
    rh = (( h__ ) >= 0 ? ( h__ ) : -( h__ ))  / rwork[2];
    if (rh > 1.) {
	h__ /= rh;
    }
L410:
    if (*t == *tout) {
	goto L719;
    }
    if ((*t - *tout) * h__ > 0.) {
	goto L711;
    }
    if (info[4] == 1) {
	goto L430;
    }
    if (info[3] == 1) {
	goto L420;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L490;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    done = (1) ;
    goto L490;
L420:
    if ((tn - *t) * h__ <= 0.) {
	goto L490;
    }
    if ((tn - *tout) * h__ > 0.) {
	goto L425;
    }
    ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[
	    29]);
    *t = tn;
    *idid = 1;
    done = (1) ;
    goto L490;
L425:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    done = (1) ;
    goto L490;
L430:
    if (info[3] == 1) {
	goto L440;
    }
    tstop = rwork[1];
    if ((tn - tstop) * h__ > 0.) {
	goto L715;
    }
    if ((tstop - *tout) * h__ < 0.) {
	goto L709;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L450;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    done = (1) ;
    goto L490;
L440:
    tstop = rwork[1];
    if ((tn - tstop) * h__ > 0.) {
	goto L715;
    }
    if ((tstop - *tout) * h__ < 0.) {
	goto L709;
    }
    if ((tn - *t) * h__ <= 0.) {
	goto L450;
    }
    if ((tn - *tout) * h__ > 0.) {
	goto L445;
    }
    ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[
	    29]);
    *t = tn;
    *idid = 1;
    done = (1) ;
    goto L490;
L445:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    done = (1) ;
    goto L490;
L450:
 
    if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn ))  + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) ))
	     {
	goto L460;
    }
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *idid = 2;
    *t = tstop;
    done = (1) ;
    goto L490;
L460:
    tnext = tn + h__;
    if ((tnext - tstop) * h__ <= 0.) {
	goto L490;
    }
    h__ = tstop - tn;
    rwork[3] = h__;

L490:
    if (done) {
	goto L580;
    }

 
 
 
 
 
 
 
 
 

L500:
 
    if (*idid == -12) {
	goto L527;
    }

 
    if (iwork[11] - iwork[10] < 500) {
	goto L510;
    }
    *idid = -1;
    goto L527;

 
L510:
    ddawts_(neq, &info[2], &rtol[1], &atol[1], &rwork[lphi], &rwork[lwt], &
	    rpar[1], &ipar[1]);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + lwt - 1] > 0.) {
	    goto L520;
	}
	*idid = -3;
	goto L527;
L520:
	;
    }

 
    r__ = ddanrm_(neq, &rwork[lphi], &rwork[lwt], &rpar[1], &ipar[1]) * 100. *
	     uround;
    if (r__ <= 1.) {
	goto L525;
    }
 
    if (info[2] == 1) {
	goto L523;
    }
    rtol[1] = r__ * rtol[1];
    atol[1] = r__ * atol[1];
    *idid = -2;
    goto L527;
L523:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	rtol[i__] = r__ * rtol[i__];
 
	atol[i__] = r__ * atol[i__];
    }
    *idid = -2;
    goto L527;
L525:

 
 
    d__1 = (( tn ) >= 0 ? ( tn ) : -( tn )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    hmin = uround * 4. * (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;

 
    if (info[7] == 0) {
	goto L526;
    }
    rh = (( h__ ) >= 0 ? ( h__ ) : -( h__ ))  / rwork[2];
    if (rh > 1.) {
	h__ /= rh;
    }
L526:

    ddastp_(&tn, &y[1], &yprime[1], neq, res, jac, &h__, &rwork[lwt], &info[1]
	    , idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[41], &rwork[le], 
	    &rwork[lwm], &iwork[1], &rwork[11], &rwork[17], &rwork[23], &
	    rwork[29], &rwork[35], &rwork[5], &rwork[6], &rwork[7], &rwork[8],
	     &hmin, &rwork[9], &iwork[6], &iwork[5], &iwork[7], &iwork[8], &
	    iwork[9], &info[10], &ntemp);
    if (ierode_ .iero != 0) {
	return 0;
    }
L527:
    if (*idid < 0) {
	goto L600;
    }

 
 
 
 

    if (info[4] != 0) {
	goto L540;
    }
    if (info[3] != 0) {
	goto L530;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L500;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *idid = 3;
    *t = *tout;
    goto L580;
L530:
    if ((tn - *tout) * h__ >= 0.) {
	goto L535;
    }
    *t = tn;
    *idid = 1;
    goto L580;
L535:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *idid = 3;
    *t = *tout;
    goto L580;
L540:
    if (info[3] != 0) {
	goto L550;
    }
    if ((tn - *tout) * h__ < 0.) {
	goto L542;
    }
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    goto L580;
L542:
    if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn ))  + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) )
	    ) {
	goto L545;
    }
    tnext = tn + h__;
    if ((tnext - tstop) * h__ <= 0.) {
	goto L500;
    }
    h__ = tstop - tn;
    goto L500;
L545:
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *idid = 2;
    *t = tstop;
    goto L580;
L550:
    if ((tn - *tout) * h__ >= 0.) {
	goto L555;
    }
    if ((d__1 = tn - tstop, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= uround * 100. * ((( tn ) >= 0 ? ( tn ) : -( tn ))  + (( h__ ) >= 0 ? ( h__ ) : -( h__ )) )
	    ) {
	goto L552;
    }
    *t = tn;
    *idid = 1;
    goto L580;
L552:
    ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *idid = 2;
    *t = tstop;
    goto L580;
L555:
    ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &
	    rwork[29]);
    *t = *tout;
    *idid = 3;
    goto L580;

 
 
 
 

L580:
    rwork[4] = tn;
    rwork[3] = h__;
    return 0;

 

 
 
 


L600:
    itemp = -(*idid);
    switch ((int)itemp) {
	case 1:  goto L610;
	case 2:  goto L620;
	case 3:  goto L630;
	case 4:  goto L690;
	case 5:  goto L690;
	case 6:  goto L640;
	case 7:  goto L650;
	case 8:  goto L660;
	case 9:  goto L670;
	case 10:  goto L675;
	case 11:  goto L680;
	case 12:  goto L685;
    }

 
 
L610:
    s_wsfi(&io___1084);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__2[0] = 15, a__1[0] = "AT CURRENT T = ";
    i__2[1] = 16, a__1[1] = xern3;
    i__2[2] = 25, a__1[2] = " 500 STEPS TAKEN ON THIS ";
    i__2[3] = 25, a__1[3] = "CALL BEFORE REACHING TOUT";
    s_cat(ch__2, a__1, i__2, &c__4, 81L);
    xermsg_("SLATEC", "DDASSL", ch__2, idid, &c__1, 6L, 6L, 81L);
    goto L690;

 
L620:
    s_wsfi(&io___1085);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "AT T = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 33, a__2[2] = " TOO MUCH ACCURACY REQUESTED FOR ";
    i__3[3] = 54, a__2[3] = "PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ";
    i__3[4] = 18, a__2[4] = "APPROPRIATE VALUES";
    s_cat(ch__3, a__2, i__3, &c__5, 128L);
    xermsg_("SLATEC", "DDASSL", ch__3, idid, &c__1, 6L, 6L, 128L);
    goto L690;

 
L630:
    s_wsfi(&io___1086);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__2[0] = 7, a__1[0] = "AT T = ";
    i__2[1] = 16, a__1[1] = xern3;
    i__2[2] = 36, a__1[2] = " SOME ELEMENT OF WT HAS BECOME .LE. ";
    i__2[3] = 3, a__1[3] = "0.0";
    s_cat(ch__4, a__1, i__2, &c__4, 62L);
    xermsg_("SLATEC", "DDASSL", ch__4, idid, &c__1, 6L, 6L, 62L);
    goto L690;

 
L640:
    s_wsfi(&io___1087);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1089);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "AT T = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 18, a__2[2] = " AND STEPSIZE H = ";
    i__3[3] = 16, a__2[3] = xern4;
    i__3[4] = 53, a__2[4] = " THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN";
    s_cat(ch__5, a__2, i__3, &c__5, 110L);
    xermsg_("SLATEC", "DDASSL", ch__5, idid, &c__1, 6L, 6L, 110L);
    goto L690;

 
L650:
    s_wsfi(&io___1090);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1091);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__4[0] = 7, a__3[0] = "AT T = ";
    i__4[1] = 16, a__3[1] = xern3;
    i__4[2] = 18, a__3[2] = " AND STEPSIZE H = ";
    i__4[3] = 16, a__3[3] = xern4;
    i__4[4] = 53, a__3[4] = " THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ";
    i__4[5] = 11, a__3[5] = "ABS(H)=HMIN";
    s_cat(ch__6, a__3, i__4, &c__6, 121L);
    xermsg_("SLATEC", "DDASSL", ch__6, idid, &c__1, 6L, 6L, 121L);
    goto L690;

 
L660:
    s_wsfi(&io___1092);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1093);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "AT T = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 18, a__2[2] = " AND STEPSIZE H = ";
    i__3[3] = 16, a__2[3] = xern4;
    i__3[4] = 33, a__2[4] = " THE ITERATION MATRIX IS SINGULAR";
    s_cat(ch__7, a__2, i__3, &c__5, 90L);
    xermsg_("SLATEC", "DDASSL", ch__7, idid, &c__1, 6L, 6L, 90L);
    goto L690;

 
L670:
    s_wsfi(&io___1094);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1095);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__4[0] = 7, a__3[0] = "AT T = ";
    i__4[1] = 16, a__3[1] = xern3;
    i__4[2] = 18, a__3[2] = " AND STEPSIZE H = ";
    i__4[3] = 16, a__3[3] = xern4;
    i__4[4] = 57, a__3[4] = " THE CORRECTOR COULD NOT CONVERGE.  ALSO, THE ERROR TEST ";
    i__4[5] = 18, a__3[5] = "FAILED REPEATEDLY.";
    s_cat(ch__8, a__3, i__4, &c__6, 132L);
    xermsg_("SLATEC", "DDASSL", ch__8, idid, &c__1, 6L, 6L, 132L);
    goto L690;

 
L675:
    s_wsfi(&io___1096);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1097);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__4[0] = 7, a__3[0] = "AT T = ";
    i__4[1] = 16, a__3[1] = xern3;
    i__4[2] = 18, a__3[2] = " AND STEPSIZE H = ";
    i__4[3] = 16, a__3[3] = xern4;
    i__4[4] = 57, a__3[4] = " THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ";
    i__4[5] = 12, a__3[5] = "TO MINUS ONE";
    s_cat(ch__9, a__3, i__4, &c__6, 126L);
    xermsg_("SLATEC", "DDASSL", ch__9, idid, &c__1, 6L, 6L, 126L);
    goto L690;

 
L680:
    s_wsfi(&io___1098);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1099);
    do_fio(&c__1, (char *)&h__, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "AT T = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 18, a__2[2] = " AND STEPSIZE H = ";
    i__3[3] = 16, a__2[3] = xern4;
    i__3[4] = 28, a__2[4] = " IRES WAS EQUAL TO MINUS TWO";
    s_cat(ch__10, a__2, i__3, &c__5, 85L);
    xermsg_("SLATEC", "DDASSL", ch__10, idid, &c__1, 6L, 6L, 85L);
    goto L690;

 
L685:
    s_wsfi(&io___1100);
    do_fio(&c__1, (char *)&tn, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1101);
    do_fio(&c__1, (char *)&ho, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "AT T = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 18, a__2[2] = " AND STEPSIZE H = ";
    i__3[3] = 16, a__2[3] = xern4;
    i__3[4] = 41, a__2[4] = " THE INITIAL YPRIME COULD NOT BE COMPUTED";
    s_cat(ch__11, a__2, i__3, &c__5, 98L);
    xermsg_("SLATEC", "DDASSL", ch__11, idid, &c__1, 6L, 6L, 98L);
    goto L690;

L690:
    info[1] = -1;
    *t = tn;
    rwork[4] = tn;
    rwork[3] = h__;
    return 0;

 

 
 
 
 
 

 

L701:
    xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE", &c__1, &c__1, 6L, 6L, 46L);
    goto L750;

L702:
    s_wsfi(&io___1102);
    do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__5[0] = 6, a__4[0] = "NEQ = ";
    i__5[1] = 8, a__4[1] = xern1;
    i__5[2] = 7, a__4[2] = " .LE. 0";
    s_cat(ch__12, a__4, i__5, &c__3, 21L);
    xermsg_("SLATEC", "DDASSL", ch__12, &c__2, &c__1, 6L, 6L, 21L);
    goto L750;

L703:
    s_wsfi(&io___1103);
    do_fio(&c__1, (char *)&mxord, (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__5[0] = 9, a__4[0] = "MAXORD = ";
    i__5[1] = 8, a__4[1] = xern1;
    i__5[2] = 13, a__4[2] = " NOT IN RANGE";
    s_cat(ch__13, a__4, i__5, &c__3, 30L);
    xermsg_("SLATEC", "DDASSL", ch__13, &c__3, &c__1, 6L, 6L, 30L);
    goto L750;

L704:
    s_wsfi(&io___1104);
    do_fio(&c__1, (char *)&lenrw, (ftnlen)sizeof(integer));
    e_wsfi();
    s_wsfi(&io___1106);
    do_fio(&c__1, (char *)&(*lrw), (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__2[0] = 29, a__1[0] = "RWORK LENGTH NEEDED, LENRW = ";
    i__2[1] = 8, a__1[1] = xern1;
    i__2[2] = 16, a__1[2] = ", EXCEEDS LRW = ";
    i__2[3] = 8, a__1[3] = xern2;
    s_cat(ch__14, a__1, i__2, &c__4, 61L);
    xermsg_("SLATEC", "DDASSL", ch__14, &c__4, &c__1, 6L, 6L, 61L);
    goto L750;

L705:
    s_wsfi(&io___1107);
    do_fio(&c__1, (char *)&leniw, (ftnlen)sizeof(integer));
    e_wsfi();
    s_wsfi(&io___1108);
    do_fio(&c__1, (char *)&(*liw), (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__2[0] = 29, a__1[0] = "IWORK LENGTH NEEDED, LENIW = ";
    i__2[1] = 8, a__1[1] = xern1;
    i__2[2] = 16, a__1[2] = ", EXCEEDS LIW = ";
    i__2[3] = 8, a__1[3] = xern2;
    s_cat(ch__14, a__1, i__2, &c__4, 61L);
    xermsg_("SLATEC", "DDASSL", ch__14, &c__5, &c__1, 6L, 6L, 61L);
    goto L750;

L706:
    xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF RTOL IS .LT. 0", &c__6, &
	    c__1, 6L, 6L, 30L);
    goto L750;

L707:
    xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF ATOL IS .LT. 0", &c__7, &
	    c__1, 6L, 6L, 30L);
    goto L750;

L708:
    xermsg_("SLATEC", "DDASSL", "ALL ELEMENTS OF RTOL AND ATOL ARE ZERO", &
	    c__8, &c__1, 6L, 6L, 38L);
    goto L750;

L709:
    s_wsfi(&io___1109);
    do_fio(&c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1110);
    do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__2[0] = 24, a__1[0] = "INFO(4) = 1 AND TSTOP = ";
    i__2[1] = 16, a__1[1] = xern3;
    i__2[2] = 15, a__1[2] = " BEHIND TOUT = ";
    i__2[3] = 16, a__1[3] = xern4;
    s_cat(ch__15, a__1, i__2, &c__4, 71L);
    xermsg_("SLATEC", "DDASSL", ch__15, &c__9, &c__1, 6L, 6L, 71L);
    goto L750;

L710:
    s_wsfi(&io___1111);
    do_fio(&c__1, (char *)&hmax, (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__5[0] = 7, a__4[0] = "HMAX = ";
    i__5[1] = 16, a__4[1] = xern3;
    i__5[2] = 9, a__4[2] = " .LT. 0.0";
    s_cat(ch__16, a__4, i__5, &c__3, 32L);
    xermsg_("SLATEC", "DDASSL", ch__16, &c__10, &c__1, 6L, 6L, 32L);
    goto L750;

L711:
    s_wsfi(&io___1112);
    do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1113);
    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__2[0] = 7, a__1[0] = "TOUT = ";
    i__2[1] = 16, a__1[1] = xern3;
    i__2[2] = 12, a__1[2] = " BEHIND T = ";
    i__2[3] = 16, a__1[3] = xern4;
    s_cat(ch__17, a__1, i__2, &c__4, 51L);
    xermsg_("SLATEC", "DDASSL", ch__17, &c__11, &c__1, 6L, 6L, 51L);
    goto L750;

L712:
    xermsg_("SLATEC", "DDASSL", "INFO(8)=1 AND H0=0.0", &c__12, &c__1, 6L, 6L,
	     20L);
    goto L750;

L713:
    xermsg_("SLATEC", "DDASSL", "SOME ELEMENT OF WT IS .LE. 0.0", &c__13, &
	    c__1, 6L, 6L, 30L);
    goto L750;

L714:
    s_wsfi(&io___1114);
    do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1115);
    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__3[0] = 7, a__2[0] = "TOUT = ";
    i__3[1] = 16, a__2[1] = xern3;
    i__3[2] = 18, a__2[2] = " TOO CLOSE TO T = ";
    i__3[3] = 16, a__2[3] = xern4;
    i__3[4] = 21, a__2[4] = " TO START INTEGRATION";
    s_cat(ch__18, a__2, i__3, &c__5, 78L);
    xermsg_("SLATEC", "DDASSL", ch__18, &c__14, &c__1, 6L, 6L, 78L);
    goto L750;

L715:
    s_wsfi(&io___1116);
    do_fio(&c__1, (char *)&tstop, (ftnlen)sizeof(doublereal));
    e_wsfi();
    s_wsfi(&io___1117);
    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__2[0] = 22, a__1[0] = "INFO(4)=1 AND TSTOP = ";
    i__2[1] = 16, a__1[1] = xern3;
    i__2[2] = 12, a__1[2] = " BEHIND T = ";
    i__2[3] = 16, a__1[3] = xern4;
    s_cat(ch__19, a__1, i__2, &c__4, 66L);
    xermsg_("SLATEC", "DDASSL", ch__19, &c__15, &c__1, 6L, 6L, 66L);
    goto L750;

L717:
    s_wsfi(&io___1118);
    do_fio(&c__1, (char *)&iwork[1], (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__5[0] = 5, a__4[0] = "ML = ";
    i__5[1] = 8, a__4[1] = xern1;
    i__5[2] = 36, a__4[2] = " ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ";
    s_cat(ch__20, a__4, i__5, &c__3, 49L);
    xermsg_("SLATEC", "DDASSL", ch__20, &c__17, &c__1, 6L, 6L, 49L);
    goto L750;

L718:
    s_wsfi(&io___1119);
    do_fio(&c__1, (char *)&iwork[2], (ftnlen)sizeof(integer));
    e_wsfi();
 
    i__5[0] = 5, a__4[0] = "MU = ";
    i__5[1] = 8, a__4[1] = xern1;
    i__5[2] = 36, a__4[2] = " ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ";
    s_cat(ch__20, a__4, i__5, &c__3, 49L);
    xermsg_("SLATEC", "DDASSL", ch__20, &c__18, &c__1, 6L, 6L, 49L);
    goto L750;

L719:
    s_wsfi(&io___1120);
    do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(doublereal));
    e_wsfi();
 
    i__6[0] = 11, a__5[0] = "TOUT = T = ";
    i__6[1] = 16, a__5[1] = xern3;
    s_cat(ch__21, a__5, i__6, &c__2, 27L);
    xermsg_("SLATEC", "DDASSL", ch__21, &c__19, &c__1, 6L, 6L, 27L);
    goto L750;

L750:
    *idid = -33;
    if (info[1] == -1) {
	xermsg_("SLATEC", "DDASSL", "REPEATED OCCURRENCES OF ILLEGAL INPUT$$RUN TERMINATED. APPARENT INFINITE LOOP", &c_n999, &c__2, 6L, 6L, 77L);
    }

    info[1] = -1;
    return 0;
 

}  

  int ddastp_(x, y, yprime, neq, res, jac, h__, wt, jstart, 
	idid, rpar, ipar, phi, delta, e, wm, iwm, alpha, beta, gamma, psi, 
	sigma, cj, cjold, hold, s, hmin, uround, iphase, jcalc, k, kold, ns, 
	nonneg, ntemp)
doublereal *x, *y, *yprime;
integer *neq;
  int (*res) (), (*jac) ();
doublereal *h__, *wt;
integer *jstart, *idid;
doublereal *rpar;
integer *ipar;
doublereal *phi, *delta, *e, *wm;
integer *iwm;
doublereal *alpha, *beta, *gamma, *psi, *sigma, *cj, *cjold, *hold, *s, *hmin,
	 *uround;
integer *iphase, *jcalc, *k, *kold, *ns, *nonneg, *ntemp;
{
     

    static integer maxit = 4;
    static doublereal xrate = .25;

     
    integer phi_dim1, phi_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    double pow_dd();

     
    static doublereal rate, hnew;
    static integer ires, knew;
    static doublereal terk, xold, erkm1, erkm2, erkp1, temp1, temp2;
    static integer i__, j, m, kdiff;
    static doublereal r__, enorm;
    static integer j1;
    static doublereal pnorm, alpha0, terkm1, terkm2;
    extern   int ddajac_();
    static doublereal terkp1, ck;
    extern doublereal ddanrm_();
    static doublereal alphas;
    extern   int ddaslv_(), ddatrp_();
    static doublereal cjlast, delnrm;
    static logical convgd;
    static doublereal oldnrm;
    static integer km1, kp1, kp2, ncf, nef, ier;
    static doublereal erk;
    static integer nsf;
    static doublereal err, est;
    static integer nsp1;

 
 
 
 
 





     
    --y;
    --yprime;
    phi_dim1 = *neq;
    phi_offset = phi_dim1 + 1;
    phi -= phi_offset;
    --wt;
    --rpar;
    --ipar;
    --delta;
    --e;
    --wm;
    --iwm;
    --alpha;
    --beta;
    --gamma;
    --psi;
    --sigma;

     





 

 
 
 
 
 


 
 
    *idid = 1;
    xold = *x;
    ncf = 0;
    nsf = 0;
    nef = 0;
    if (*jstart != 0) {
	goto L120;
    }

 
 
    iwm[14] = 0;
    iwm[15] = 0;
    *k = 1;
    *kold = 0;
    *hold = 0.;
    *jstart = 1;
    psi[1] = *h__;
    *cjold = 1. / *h__;
    *cj = *cjold;
    *s = 100.;
    *jcalc = -1;
    delnrm = 1.;
    *iphase = 0;
    *ns = 0;
L120:





 

 
 
 
 

L200:
    kp1 = *k + 1;
    kp2 = *k + 2;
    km1 = *k - 1;
    xold = *x;
    if (*h__ != *hold || *k != *kold) {
	*ns = 0;
    }
 
    i__1 = *ns + 1, i__2 = *kold + 2;
    *ns = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    nsp1 = *ns + 1;
    if (kp1 < *ns) {
	goto L230;
    }

    beta[1] = 1.;
    alpha[1] = 1.;
    temp1 = *h__;
    gamma[1] = 0.;
    sigma[1] = 1.;
    i__1 = kp1;
    for (i__ = 2; i__ <= i__1; ++i__) {
	temp2 = psi[i__ - 1];
	psi[i__ - 1] = temp1;
	beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2;
	temp1 = temp2 + *h__;
	alpha[i__] = *h__ / temp1;
	sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__];
	gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__;
 
    }
    psi[kp1] = temp1;
L230:

 
    alphas = 0.;
    alpha0 = 0.;
    i__1 = *k;
    for (i__ = 1; i__ <= i__1; ++i__) {
	alphas -= 1. / i__;
	alpha0 -= alpha[i__];
 
    }

 
    cjlast = *cj;
    *cj = -alphas / *h__;

 
    ck = (d__1 = alpha[kp1] + alphas - alpha0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
    d__1 = ck, d__2 = alpha[kp1];
    ck = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;

 
    temp1 = (1. - xrate) / (xrate + 1.);
    temp2 = 1. / temp1;
    if (*cj / *cjold < temp1 || *cj / *cjold > temp2) {
	*jcalc = -1;
    }
    if (*cj != cjlast) {
	*s = 100.;
    }

 
    if (kp1 < nsp1) {
	goto L280;
    }
    i__1 = kp1;
    for (j = nsp1; j <= i__1; ++j) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1];
	}
 
    }
L280:

 
    *x += *h__;





 

 
 
 
 


 
L300:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] = phi[i__ + phi_dim1];
 
	yprime[i__] = 0.;
    }
    i__1 = kp1;
    for (j = 2; j <= i__1; ++j) {
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    y[i__] += phi[i__ + j * phi_dim1];
 
	    yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1];
	}
 
    }
    pnorm = ddanrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]);



 
 
    convgd = (1) ;
    m = 0;
    ++iwm[12];
    ires = 0;
    (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ierode_ .iero != 0) {
	return 0;
    }
    if (ires < 0) {
	goto L380;
    }


 
 
 
 
 
    if (*jcalc != -1) {
	goto L340;
    }
    ++iwm[13];
    *jcalc = 0;
    ddajac_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ier, &wt[1], &e[1]
	    , &wm[1], &iwm[1], res, &ires, uround, jac, &rpar[1], &ipar[1], 
	    ntemp);
    if (ierode_ .iero != 0) {
	return 0;
    }
    *cjold = *cj;
    *s = 100.;
    if (ires < 0) {
	goto L380;
    }
    if (ier != 0) {
	goto L380;
    }
    nsf = 0;


 
L340:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	e[i__] = 0.;
    }


 
L350:

 
    temp1 = 2. / (*cj / *cjold + 1.);
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	delta[i__] *= temp1;
    }

 
 
    ddaslv_(neq, &delta[1], &wm[1], &iwm[1]);

 
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] -= delta[i__];
	e[i__] -= delta[i__];
 
	yprime[i__] -= *cj * delta[i__];
    }

 
    delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm <= *uround * 100. * pnorm) {
	goto L375;
    }
    if (m > 0) {
	goto L365;
    }
    oldnrm = delnrm;
    goto L367;
L365:
    d__1 = delnrm / oldnrm;
    d__2 = 1. / m;
    rate = pow_dd(&d__1, &d__2);
    if (rate > .9) {
	goto L370;
    }
    *s = rate / (1. - rate);
L367:
    if (*s * delnrm <= .33) {
	goto L375;
    }

 
 
 
 
    ++m;
    if (m >= maxit) {
	goto L370;
    }

 
 
    ++iwm[12];
    ires = 0;
    (*res)(x, &y[1], &yprime[1], &delta[1], &ires, &rpar[1], &ipar[1]);
    if (ierode_ .iero != 0) {
	return 0;
    }
    if (ires < 0) {
	goto L380;
    }
    goto L350;


 
 
 
 
L370:
    if (*jcalc == 0) {
	goto L380;
    }
    *jcalc = -1;
    goto L300;


 
 
 
 
L375:
    if (*nonneg == 0) {
	goto L390;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = y[i__];
	delta[i__] = (( d__1 ) <= ( 0. ) ? ( d__1 ) : ( 0. )) ;
    }
    delnrm = ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    if (delnrm > .33) {
	goto L380;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	e[i__] -= delta[i__];
    }
    goto L390;


 
 
 
L380:
    convgd = (0) ;
L390:
    *jcalc = 1;
    if (! convgd) {
	goto L600;
    }





 

 
 
 
 
 
 


 
    enorm = ddanrm_(neq, &e[1], &wt[1], &rpar[1], &ipar[1]);
    erk = sigma[*k + 1] * enorm;
    terk = (*k + 1) * erk;
    est = erk;
    knew = *k;
    if (*k == 1) {
	goto L430;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__];
    }
    erkm1 = sigma[*k] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]);
    terkm1 = *k * erkm1;
    if (*k > 2) {
	goto L410;
    }
    if (terkm1 <= terk * .5) {
	goto L420;
    }
    goto L430;
L410:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__];
    }
    erkm2 = sigma[*k - 1] * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]
	    );
    terkm2 = (*k - 1) * erkm2;
    if ((( terkm1 ) >= ( terkm2 ) ? ( terkm1 ) : ( terkm2 ))  > terk) {
	goto L430;
    }
 
L420:
    knew = *k - 1;
    est = erkm1;


 
 
L430:
    err = ck * enorm;
    if (err > 1.) {
	goto L600;
    }





 

 
 
 
 
 
 

    *idid = 1;
    ++iwm[11];
    kdiff = *k - *kold;
    *kold = *k;
    *hold = *h__;


 
 
 
 
 
    if (knew == km1 || *k == iwm[3]) {
	*iphase = 1;
    }
    if (*iphase == 0) {
	goto L545;
    }
    if (knew == km1) {
	goto L540;
    }
    if (*k == iwm[3]) {
	goto L550;
    }
    if (kp1 >= *ns || kdiff == 1) {
	goto L550;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1];
    }
    erkp1 = 1. / (*k + 2) * ddanrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]
	    );
    terkp1 = (*k + 2) * erkp1;
    if (*k > 1) {
	goto L520;
    }
    if (terkp1 >= terk * .5) {
	goto L550;
    }
    goto L530;
L520:
    if (terkm1 <= (( terk ) <= ( terkp1 ) ? ( terk ) : ( terkp1 )) ) {
	goto L540;
    }
    if (terkp1 >= terk || *k == iwm[3]) {
	goto L550;
    }

 
L530:
    *k = kp1;
    est = erkp1;
    goto L550;

 
L540:
    *k = km1;
    est = erkm1;
    goto L550;

 
 
L545:
    *k = kp1;
    hnew = *h__ * 2.;
    *h__ = hnew;
    goto L575;


 
 
L550:
    hnew = *h__;
    temp2 = (doublereal) (*k + 1);
    d__1 = est * 2. + 1e-4;
    d__2 = -1. / temp2;
    r__ = pow_dd(&d__1, &d__2);
    if (r__ < 2.) {
	goto L555;
    }
    hnew = *h__ * 2.;
    goto L560;
L555:
    if (r__ > 1.) {
	goto L560;
    }
 
    d__1 = .5, d__2 = (( .9 ) <= ( r__ ) ? ( .9 ) : ( r__ )) ;
    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    hnew = *h__ * r__;
L560:
    *h__ = hnew;


 
L575:
    if (*kold == iwm[3]) {
	goto L585;
    }
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	phi[i__ + kp2 * phi_dim1] = e[i__];
    }
L585:
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	phi[i__ + kp1 * phi_dim1] += e[i__];
    }
    i__1 = kp1;
    for (j1 = 2; j1 <= i__1; ++j1) {
	j = kp1 - j1 + 1;
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1];
	}
    }
    return 0;





 

 
 
 
 
 
 
 

L600:
    *iphase = 1;

 
    *x = xold;
    if (kp1 < nsp1) {
	goto L630;
    }
    i__2 = kp1;
    for (j = nsp1; j <= i__2; ++j) {
	temp1 = 1. / beta[j];
	i__1 = *neq;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1];
	}
 
    }
L630:
    i__2 = kp1;
    for (i__ = 2; i__ <= i__2; ++i__) {
 
	psi[i__ - 1] = psi[i__] - *h__;
    }


 
 
    if (convgd) {
	goto L660;
    }
    ++iwm[15];


 
 
 
    if (ier == 0) {
	goto L650;
    }

 
 
 
 
    ++nsf;
    r__ = .25;
    *h__ *= r__;
    if (nsf < 3 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -8;
    goto L675;


 
 
 
 
L650:
    if (ires > -2) {
	goto L655;
    }
    *idid = -11;
    goto L675;
L655:
    ++ncf;
    r__ = .25;
    *h__ *= r__;
    if (ncf < 10 && (( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -7;
    if (ires < 0) {
	*idid = -10;
    }
    if (nef >= 3) {
	*idid = -9;
    }
    goto L675;


 
 
 
L660:
    ++nef;
    ++iwm[14];
    if (nef > 1) {
	goto L665;
    }

 
 
 
    *k = knew;
    temp2 = (doublereal) (*k + 1);
    d__1 = est * 2. + 1e-4;
    d__2 = -1. / temp2;
    r__ = pow_dd(&d__1, &d__2) * .9;
 
    d__1 = .25, d__2 = (( .9 ) <= ( r__ ) ? ( .9 ) : ( r__ )) ;
    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    *h__ *= r__;
    if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;

 
 
 
L665:
    if (nef > 2) {
	goto L670;
    }
    *k = knew;
    *h__ *= .25;
    if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;

 
 
L670:
    *k = 1;
    *h__ *= .25;
    if ((( *h__ ) >= 0 ? ( *h__ ) : -( *h__ ))  >= *hmin) {
	goto L690;
    }
    *idid = -6;
    goto L675;




 
 
L675:
    ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]);
    return 0;


 
L690:
    goto L200;

 
}  

  int ddatrp_(x, xout, yout, ypout, neq, kold, phi, psi)
doublereal *x, *xout, *yout, *ypout;
integer *neq, *kold;
doublereal *phi, *psi;
{
     
    integer phi_dim1, phi_offset, i__1, i__2;

     
    static doublereal temp1, c__, d__;
    static integer i__, j;
    static doublereal gamma;
    static integer koldp1;
     
    --yout;
    --ypout;
    phi_dim1 = *neq;
    phi_offset = phi_dim1 + 1;
    phi -= phi_offset;
    --psi;

     
    koldp1 = *kold + 1;
    temp1 = *xout - *x;
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yout[i__] = phi[i__ + phi_dim1];
 
	ypout[i__] = 0.;
    }
    c__ = 1.;
    d__ = 0.;
    gamma = temp1 / psi[1];
    i__1 = koldp1;
    for (j = 2; j <= i__1; ++j) {
	d__ = d__ * gamma + c__ / psi[j - 1];
	c__ *= gamma;
	gamma = (temp1 + psi[j - 1]) / psi[j];
	i__2 = *neq;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    yout[i__] += c__ * phi[i__ + j * phi_dim1];
 
	    ypout[i__] += d__ * phi[i__ + j * phi_dim1];
	}
 
    }
    return 0;

 
}  

  int ddawts_(neq, iwt, rtol, atol, y, wt, rpar, ipar)
integer *neq, *iwt;
doublereal *rtol, *atol, *y, *wt, *rpar;
integer *ipar;
{
     
    integer i__1;
    doublereal d__1;

     
    static integer i__;
    static doublereal atoli, rtoli;

 
 
 
 
 
 
 
 

 
 
 
 
 
 

 
 
 
 
 
 
 
 



 
     
    --ipar;
    --rpar;
    --wt;
    --y;
    --atol;
    --rtol;

     
    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = *neq;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*iwt == 0) {
	    goto L10;
	}
	rtoli = rtol[i__];
	atoli = atol[i__];
L10:
	wt[i__] = rtoli * (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + atoli;
 
    }
    return 0;
 

}  

  int xerhlt_(messg, messg_len)
char *messg;
ftnlen messg_len;
{
     
      int s_stop();

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 

 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
    s_stop("", 0L);
}  

 
  int xermsg_(librar, subrou, messg, nerr, level, librar_len, 
	subrou_len, messg_len)
char *librar, *subrou, *messg;
integer *nerr, *level;
ftnlen librar_len;
ftnlen subrou_len;
ftnlen messg_len;
{
     
    address a__1[2];
    integer i__1, i__2[2];
    char ch__1[87];

     
      int s_copy();
    integer i_len(), s_wsfi(), do_fio(), e_wsfi();
      int s_cat();

     
    static char temp[72];
    static integer i__, ltemp;
    extern   int xerhlt_();
    static integer lkntrl, mkntrl;
    extern   int xerprn_();

     
    static icilist io___1178 = { 0, temp, 0, "('ERROR NUMBER = ', I8)", 72, 1 
	    };


 
 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 

 
 
 

    if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || *
	    level > 2) {
	xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, 4L, 91L);
	xerhlt_(" ***XERMSG -- INVALID INPUT", 27L);
	return 0;
    }

 

    lkntrl = 1;
    mkntrl = 1;

 
 

 
 

    if (lkntrl != 0) {
	s_copy(temp, "MESSAGE FROM ROUTINE ", 21L, 21L);
 
	i__1 = i_len(subrou, subrou_len);
	i__ = (( i__1 ) <= ( 16 ) ? ( i__1 ) : ( 16 )) ;
	s_copy(temp + 21, subrou, i__, i__);
	i__1 = i__ + 21;
	s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, 12L);
	ltemp = i__ + 33;
 
	i__1 = i_len(librar, librar_len);
	i__ = (( i__1 ) <= ( 16 ) ? ( i__1 ) : ( 16 )) ;
	i__1 = ltemp;
	s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__);
	i__1 = ltemp + i__;
	s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, 1L);
	ltemp = ltemp + i__ + 1;
	xerprn_(" ***", &c_n1, temp, &c__72, 4L, ltemp);
    }

 
 
 
 
 
 
 
 
 
 
 
 
 

    if (lkntrl > 0) {

 

	if (*level <= 0) {
	    s_copy(temp, "INFORMATIVE MESSAGE,", 20L, 20L);
	    ltemp = 20;
	} else if (*level == 1) {
	    s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", 30L, 30L);
	    ltemp = 30;
	} else {
	    s_copy(temp, "FATAL ERROR,", 12L, 12L);
	    ltemp = 12;
	}

 

	if (mkntrl == 2 && *level >= 1 || mkntrl == 1 && *level == 2) {
	    i__1 = ltemp;
	    s_copy(temp + i__1, " PROGRAM ABORTED.", ltemp + 17 - i__1, 17L);
	    ltemp += 17;
	} else {
	    i__1 = ltemp;
	    s_copy(temp + i__1, " PROGRAM CONTINUES.", ltemp + 19 - i__1, 19L)
		    ;
	    ltemp += 19;
	}

	xerprn_(" ***", &c_n1, temp, &c__72, 4L, ltemp);
    }

 

    xerprn_(" *  ", &c_n1, messg, &c__72, 4L, messg_len);

 

    if (lkntrl > 0) {
	s_wsfi(&io___1178);
	do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer));
	e_wsfi();
	for (i__ = 16; i__ <= 22; ++i__) {
	    if (*(unsigned char *)&temp[i__ - 1] != ' ') {
		goto L20;
	    }
 
	}

L20:
 
	i__2[0] = 15, a__1[0] = temp;
	i__2[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1);
	s_cat(ch__1, a__1, i__2, &c__2, 87L);
	xerprn_(" *  ", &c_n1, ch__1, &c__72, 4L, 23 - (i__ - 1) + 15);
    }

 


    if (lkntrl != 0) {
	xerprn_(" *  ", &c_n1, " ", &c__72, 4L, 1L);
	xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, 4L, 14L);
	xerprn_("    ", &c__0, " ", &c__72, 4L, 1L);
    }

 
 

 
    if (*level <= 0 || *level == 1 && mkntrl <= 1) {
	return 0;
    }

 
 
 


    if (lkntrl > 0) {
	if (*level == 1) {
	    xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", &
		    c__72, 4L, 35L);
	} else {
	    xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, 
		    4L, 29L);
	}
	xerhlt_(" ", 1L);
    }
    return 0;
}  

 
  int xerprn_(prefix, npref, messg, nwrap, prefix_len, 
	messg_len)
char *prefix;
integer *npref;
char *messg;
integer *nwrap;
ftnlen prefix_len;
ftnlen messg_len;
{
     
    integer i__1, i__2;

     
    integer i_len();
      int s_copy();
    integer s_wsfe(), do_fio(), e_wsfe(), i_indx(), s_cmp();

     
    static integer i__, n;
    static char cbuff[148];
    static integer lpref, nextc, lwrap, nunit, iu[5], lpiece, idelta, lenmsg;
    extern   int xgetua_();

     
    static cilist io___1187 = { 0, 0, 0, "(A)", 0 };
    static cilist io___1191 = { 0, 0, 0, "(A)", 0 };
 
    xgetua_(iu, &nunit);
    n = 6;
    i__1 = nunit;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (iu[i__ - 1] == 0) {
	    iu[i__ - 1] = n;
	}
 
    }

 

 

 

    if (*npref < 0) {
	lpref = i_len(prefix, prefix_len);
    } else {
	lpref = *npref;
    }
    lpref = (( 16 ) <= ( lpref ) ? ( 16 ) : ( lpref )) ;
    if (lpref != 0) {
	s_copy(cbuff, prefix, lpref, prefix_len);
    }

 

 

 
    i__1 = 16, i__2 = (( 132 ) <= ( *nwrap ) ? ( 132 ) : ( *nwrap )) ;
    lwrap = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;

 

    lenmsg = i_len(messg, messg_len);
    n = lenmsg;
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*(unsigned char *)&messg[lenmsg - 1] != ' ') {
	    goto L30;
	}
	--lenmsg;
 
    }
L30:

 

    if (lenmsg == 0) {
	i__1 = lpref;
	s_copy(cbuff + i__1, " ", lpref + 1 - i__1, 1L);
	i__1 = nunit;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    io___1187.ciunit = iu[i__ - 1];
	    s_wsfe(&io___1187);
	    do_fio(&c__1, cbuff, lpref + 1);
	    e_wsfe();
 
	}
	return 0;
    }
 

    nextc = 1;
L50:
    lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), 2L);
    if (lpiece == 0) {

 

	idelta = 0;
 
	i__1 = lwrap, i__2 = lenmsg + 1 - nextc;
	lpiece = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	if (lpiece < lenmsg + 1 - nextc) {
	    for (i__ = lpiece + 1; i__ >= 2; --i__) {
		i__1 = nextc + i__ - 2;
		if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, 1L) == 0)
			 {
		    lpiece = i__ - 1;
		    idelta = 1;
		    goto L54;
		}
 
	    }
	}
L54:
	i__1 = lpref;
	s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, 
		nextc + lpiece - 1 - (nextc - 1));
	nextc = nextc + lpiece + idelta;
    } else if (lpiece == 1) {

 
 

	nextc += 2;
	goto L50;
    } else if (lpiece > lwrap + 1) {

 

	idelta = 0;
	lpiece = lwrap;
	for (i__ = lpiece + 1; i__ >= 2; --i__) {
	    i__1 = nextc + i__ - 2;
	    if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, 1L) == 0) {
		lpiece = i__ - 1;
		idelta = 1;
		goto L58;
	    }
 
	}
L58:
	i__1 = lpref;
	s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, 
		nextc + lpiece - 1 - (nextc - 1));
	nextc = nextc + lpiece + idelta;
    } else {

 
 

	--lpiece;
	i__1 = lpref;
	s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, 
		nextc + lpiece - 1 - (nextc - 1));
	nextc = nextc + lpiece + 2;
    }

 

    i__1 = nunit;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___1191.ciunit = iu[i__ - 1];
	s_wsfe(&io___1191);
	do_fio(&c__1, cbuff, lpref + lpiece);
	e_wsfe();
 
    }

    if (nextc <= lenmsg) {
	goto L50;
    }
    return 0;
}  

 
  int xgetua_(iunita, n)
integer *iunita, *n;
{
     
    integer i__1;

     
    static integer i__;
     
    --iunita;

     
    if (xeruni_ .nunit <= 0) {
	xeruni_ .nunit = 1;
	xeruni_ .iunit[0] = 0;
    }
    *n = xeruni_ .nunit;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	iunita[i__] = xeruni_ .iunit[i__ - 1];
 
    }
    return 0;
}  

 
  int xsetua_(iunita, n)
integer *iunita, *n;
{
     
    address a__1[2];
    integer i__1[2], i__2;
    char ch__1[37];

     
    integer s_wsfi(), do_fio(), e_wsfi();
      int s_cat();

     
    static char xern1[8];
    static integer i__;
    extern   int xermsg_();

     
    static icilist io___1194 = { 0, xern1, 0, "(I8)", 8, 1 };
     
    --iunita;

     
    if (*n < 1 || *n > 5) {
	s_wsfi(&io___1194);
	do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
	e_wsfi();
 
	i__1[0] = 29, a__1[0] = "INVALID NUMBER OF UNITS, N = ";
	i__1[1] = 8, a__1[1] = xern1;
	s_cat(ch__1, a__1, i__1, &c__2, 37L);
	xermsg_("SLATEC", "XSETUA", ch__1, &c__1, &c__2, 6L, 6L, 37L);
	return 0;
    }

    i__2 = *n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	xeruni_ .iunit[i__ - 1] = iunita[i__];
 
    }
    xeruni_ .nunit = *n;
    return 0;
}  

 
  int dqag0_(f, a, b, epsabs, epsrel, result, abserr, work, 
	lwork, iwork, liwork, ifail)
doublereal (*f) ();
doublereal *a, *b, *epsabs, *epsrel, *result, *abserr, *work;
integer *lwork, *iwork, *liwork, *ifail;
{
     
    doublereal d__1, d__2;

     
    extern   int dqags_();
    static integer limit, ibl, iel, ier, irl;
     
    --work;
    --iwork;

     
    if (*lwork < 4) {
	goto L20;
    }
    if (*liwork < *lwork / 8 + 2) {
	goto L20;
    }
 
    limit = *lwork / 4;
 
    ibl = limit + 1;
    iel = limit + ibl;
    irl = limit + iel;
 
    d__1 = (( *epsabs ) >= 0 ? ( *epsabs ) : -( *epsabs )) ;
    d__2 = (( *epsrel ) >= 0 ? ( *epsrel ) : -( *epsrel )) ;
    dqags_(f, a, b, &d__1, &d__2, &work[1], &work[ibl], &work[iel], &work[irl]
	    , &limit, &iwork[1], liwork, result, abserr, &ier);
    if (ier != 0) {
	goto L40;
    }
    *ifail = 0;
    goto L60;
 
L20:
    ier = 6;
L40:
    *ifail = 1;
L60:
    return 0;
}  

 
  int dqags_(f, a, b, epsabs, epsrel, alist__, blist, elist, 
	rlist, limit, iord, liord, result, abserr, ier)
doublereal (*f) ();
doublereal *a, *b, *epsabs, *epsrel, *alist__, *blist, *elist, *rlist;
integer *limit, *iord, *liord;
doublereal *result, *abserr;
integer *ier;
{
     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    static doublereal area, dres;
    static integer ksgn, last, nres;
    static doublereal area1, area2;
    static integer last1;
    static doublereal area12;
    static integer k;
    static doublereal small, erro12;
    extern   int order_();
    static integer ierro;
    static doublereal a1, a2, b1, b2, defab1, defab2, oflow;
    static integer ktmin, nrmax;
    static doublereal uflow;
    static logical noext;
    static integer iroff1, iroff2, iroff3;
    static doublereal res3la[3], error1, error2;
    static integer id, numrl2;
    static doublereal rlist2[52], defabs;
    extern doublereal dlamch_();
    static doublereal epmach;
    extern   int epsalg_();
    static doublereal erlarg, abseps, correc, errbnd, resabs, erlast, errmax;
    static integer maxerr;
    static doublereal reseps;
    static logical extrap;
    static doublereal ertest;
    extern   int quarul_();
    static doublereal errsum;
     
    --rlist;
    --elist;
    --blist;
    --alist__;
    --iord;
    epmach = dlamch_("p", 1L);
    uflow = dlamch_("u", 1L);
    oflow = dlamch_("o", 1L);
    ierajf_ .iero = 0;
    last1 = 1;
    *ier = 0;
    ierro = 0;
    quarul_(f, a, b, result, abserr, &defabs, &resabs);
    if (ierajf_ .iero > 0) {
	*ier = 6;
	return 0;
    }

 

    dres = (( *result ) >= 0 ? ( *result ) : -( *result )) ;
 
    d__1 = *epsabs, d__2 = *epsrel * dres;
    errbnd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if (*abserr <= epmach * 100. * defabs && *abserr > errbnd) {
	*ier = 2;
    }
    if (*limit < 2 && *abserr > errbnd) {
	*ier = 1;
    }
    if (*ier != 0 || *abserr <= errbnd) {
	goto L320;
    }

 
 

    alist__[1] = *a;
    blist[1] = *b;
    rlist[1] = *result;
    rlist2[0] = *result;
    errmax = *abserr;
    maxerr = 1;
    area = *result;
    errsum = *abserr;
    *abserr = oflow;
    nrmax = 1;
    nres = 0;
    numrl2 = 2;
    ktmin = 0;
    extrap = (0) ;
    noext = (0) ;
    iroff1 = 0;
    iroff2 = 0;
    iroff3 = 0;
    ksgn = -1;
    if (dres >= (1. - epmach * 50.) * defabs) {
	ksgn = 1;
    }

 
 

    if (*limit < 2) {
	goto L220;
    }
    i__1 = *limit;
    for (last = 2; last <= i__1; ++last) {

 
 

	last1 = last;
	a1 = alist__[maxerr];
	b1 = (alist__[maxerr] + blist[maxerr]) * .5;
	a2 = b1;
	b2 = blist[maxerr];
	erlast = errmax;
	quarul_(f, &a1, &b1, &area1, &error1, &resabs, &defab1);
	if (ierajf_ .iero > 0) {
	    *ier = 6;
	    return 0;
	}
	quarul_(f, &a2, &b2, &area2, &error2, &resabs, &defab2);
	if (ierajf_ .iero > 0) {
	    *ier = 6;
	    return 0;
	}

 
 

	area12 = area1 + area2;
	erro12 = error1 + error2;
	errsum = errsum + erro12 - errmax;
	area = area + area12 - rlist[maxerr];
	if (defab1 == error1 || defab2 == error2) {
	    goto L40;
	}
	if ((d__1 = rlist[maxerr] - area12, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (( area12 ) >= 0 ? ( area12 ) : -( area12 ))  * 1e-5 ||
		 erro12 < errmax * .99) {
	    goto L20;
	}
	if (extrap) {
	    ++iroff2;
	}
	if (! extrap) {
	    ++iroff1;
	}
L20:
	if (last > 10 && erro12 > errmax) {
	    ++iroff3;
	}
L40:
	rlist[maxerr] = area1;
	rlist[last] = area2;
 
	d__1 = *epsabs, d__2 = *epsrel * (( area ) >= 0 ? ( area ) : -( area )) ;
	errbnd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	if (errsum <= errbnd) {
	    goto L280;
	}

 
 

	if (iroff1 + iroff2 >= 10 || iroff3 >= 20) {
	    *ier = 2;
	}
	if (iroff2 >= 5) {
	    ierro = 3;
	}

 
 

	if (last == *limit) {
	    *ier = 1;
	}

 
 

 
	d__1 = (( a1 ) >= 0 ? ( a1 ) : -( a1 )) , d__2 = (( b2 ) >= 0 ? ( b2 ) : -( b2 )) ;
	if ((( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 ))  <= (epmach * 100. + 1.) * ((( a2 ) >= 0 ? ( a2 ) : -( a2 ))  + uflow * 1e3)) 
		{
	    *ier = 4;
	}
	if (*ier != 0) {
	    goto L220;
	}

 

	if (error2 > error1) {
	    goto L60;
	}
	alist__[last] = a2;
	blist[maxerr] = b1;
	blist[last] = b2;
	elist[maxerr] = error1;
	elist[last] = error2;
	goto L80;
L60:
	alist__[maxerr] = a2;
	alist__[last] = a1;
	blist[last] = b1;
	rlist[maxerr] = area2;
	rlist[last] = area1;
	elist[maxerr] = error2;
	elist[last] = error1;

 
 
 
 
 

L80:
	order_(limit, &last, &maxerr, &errmax, &elist[1], &iord[1], liord, &
		nrmax);
	if (last == 2) {
	    goto L180;
	}
	if (noext) {
	    goto L200;
	}
	erlarg -= erlast;
	if ((d__1 = b1 - a1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) {
	    erlarg += erro12;
	}
	if (extrap) {
	    goto L100;
	}

 
 

	if ((d__1 = blist[maxerr] - alist__[maxerr], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) {
	    goto L200;
	}
	extrap = (1) ;
	nrmax = 2;
L100:
	if (ierro == 3 || erlarg <= ertest) {
	    goto L140;
	}

 
 
 
 

	id = nrmax;
	i__2 = dqa001_ .jupbnd;
	for (k = id; k <= i__2; ++k) {
	    maxerr = iord[nrmax];
	    errmax = elist[maxerr];
	    if ((d__1 = blist[maxerr] - alist__[maxerr], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > small) {
		goto L200;
	    }
	    ++nrmax;
 
	}

 

L140:
	++numrl2;
	rlist2[numrl2 - 1] = area;
	epsalg_(&numrl2, rlist2, &reseps, &abseps, res3la, &nres);
	++ktmin;
	if (ktmin > 5 && *abserr < errsum * .001) {
	    *ier = 5;
	}
	if (abseps >= *abserr) {
	    goto L160;
	}
	ktmin = 0;
	*abserr = abseps;
	*result = reseps;
	correc = erlarg;
 
	d__1 = *epsabs, d__2 = *epsrel * (( reseps ) >= 0 ? ( reseps ) : -( reseps )) ;
	ertest = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	if (*abserr <= ertest) {
	    goto L220;
	}

 

L160:
	if (numrl2 == 1) {
	    noext = (1) ;
	}
	if (*ier == 5) {
	    goto L220;
	}
	maxerr = iord[1];
	errmax = elist[maxerr];
	nrmax = 1;
	extrap = (0) ;
	small *= .5;
	erlarg = errsum;
	goto L200;
L180:
	small = (d__1 = *b - *a, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * .375;
	erlarg = errsum;
	ertest = errbnd;
	rlist2[1] = area;
L200:
	;
    }

 
 

L220:
    if (*abserr == oflow) {
	goto L280;
    }
    if (*ier + ierro == 0) {
	goto L260;
    }
    if (ierro == 3) {
	*abserr += correc;
    }
    if (*ier == 0) {
	*ier = 3;
    }
    if (*result != 0. && area != 0.) {
	goto L240;
    }
    if (*abserr > errsum) {
	goto L280;
    }
    if (area == 0.) {
	goto L320;
    }
    goto L260;
L240:
    if (*abserr / (( *result ) >= 0 ? ( *result ) : -( *result ))  > errsum / (( area ) >= 0 ? ( area ) : -( area )) ) {
	goto L280;
    }

 

L260:
 
    d__1 = (( *result ) >= 0 ? ( *result ) : -( *result )) , d__2 = (( area ) >= 0 ? ( area ) : -( area )) ;
    if (ksgn == -1 && (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 ))  <= defabs * .01) {
	goto L320;
    }
    if (.01 > *result / area || *result / area > 100. || errsum > (( area ) >= 0 ? ( area ) : -( area )) ) {
	*ier = 6;
    }
    goto L320;

 

L280:
    *result = 0.;
    i__1 = last;
    for (k = 1; k <= i__1; ++k) {
	*result += rlist[k];
 
    }
    *abserr = errsum;
L320:
    if (*ier > 2) {
	--(*ier);
    }
    iord[1] = last1 << 2;
    return 0;
}  

 
  int epsalg_(n, epstab, result, abserr, res3la, nres)
integer *n;
doublereal *epstab, *result, *abserr, *res3la;
integer *nres;
{
     

    static integer limexp = 50;

     
    integer i__1;
    doublereal d__1, d__2, d__3;

     
    static doublereal e1abs;
    static integer i__;
    static doublereal e0, e1, e2, e3, error, oflow;
    static integer k1, k2, k3;
    static doublereal delta1, delta2, delta3;
    static integer ib, ie;
    extern doublereal dlamch_();
    static doublereal epmach, ss, epsinf;
    static integer newelm, ib2, ind;
    static doublereal res;
    static integer num;
    static doublereal err1, err2, err3, tol1, tol2, tol3;
    --res3la;
    --epstab;
    epmach = dlamch_("p", 1L);
    oflow = dlamch_("o", 1L);

    ++(*nres);
    *abserr = oflow;
    *result = epstab[*n];
    if (*n < 3) {
	goto L200;
    }
    epstab[*n + 2] = epstab[*n];
    newelm = (*n - 1) / 2;
    epstab[*n] = oflow;
    num = *n;
    k1 = *n;
    i__1 = newelm;
    for (i__ = 1; i__ <= i__1; ++i__) {
	k2 = k1 - 1;
	k3 = k1 - 2;
	res = epstab[k1 + 2];
	e0 = epstab[k3];
	e1 = epstab[k2];
	e2 = res;
	e1abs = (( e1 ) >= 0 ? ( e1 ) : -( e1 )) ;
	delta2 = e2 - e1;
	err2 = (( delta2 ) >= 0 ? ( delta2 ) : -( delta2 )) ;
 
	d__1 = (( e2 ) >= 0 ? ( e2 ) : -( e2 )) ;
	tol2 = (( d__1 ) >= ( e1abs ) ? ( d__1 ) : ( e1abs ))  * epmach;
	delta3 = e1 - e0;
	err3 = (( delta3 ) >= 0 ? ( delta3 ) : -( delta3 )) ;
 
	d__1 = e1abs, d__2 = (( e0 ) >= 0 ? ( e0 ) : -( e0 )) ;
	tol3 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 ))  * epmach;
	if (err2 > tol2 || err3 > tol3) {
	    goto L20;
	}

 
 
 
 

	*result = res;
	*abserr = err2 + err3;
	goto L200;
L20:
	e3 = epstab[k1];
	epstab[k1] = e1;
	delta1 = e1 - e3;
	err1 = (( delta1 ) >= 0 ? ( delta1 ) : -( delta1 )) ;
 
	d__1 = e1abs, d__2 = (( e3 ) >= 0 ? ( e3 ) : -( e3 )) ;
	tol1 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 ))  * epmach;

 
 

	if (err1 < tol1 || err2 < tol2 || err3 < tol3) {
	    goto L40;
	}
	ss = 1. / delta1 + 1. / delta2 - 1. / delta3;
	epsinf = (d__1 = ss * e1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

 
 

 

	if (epsinf > 1e-4) {
	    goto L60;
	}
L40:
	*n = i__ + i__ - 1;
	goto L100;

 
 

L60:
	res = e1 + 1. / ss;
	epstab[k1] = res;
	k1 += -2;
	error = err2 + (d__1 = res - e2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + err3;
	if (error > *abserr) {
	    goto L80;
	}
	*abserr = error;
	*result = res;
L80:
	;
    }

 

L100:
    if (*n == limexp) {
	*n = (limexp / 2 << 1) - 1;
    }
    ib = 1;
    if (num / 2 << 1 == num) {
	ib = 2;
    }
    ie = newelm + 1;
    i__1 = ie;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ib2 = ib + 2;
	epstab[ib] = epstab[ib2];
	ib = ib2;
 
    }
    if (num == *n) {
	goto L160;
    }
    ind = num - *n + 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	epstab[i__] = epstab[ind];
	++ind;
 
    }
L160:
    if (*nres >= 4) {
	goto L180;
    }
    res3la[*nres] = *result;
    *abserr = oflow;
    goto L200;

 

L180:
    *abserr = (d__1 = *result - res3la[3], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = *result - 
	    res3la[2], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + (d__3 = *result - res3la[1], (( d__3 ) >= 0 ? ( d__3 ) : -( d__3 )) );
    res3la[1] = res3la[2];
    res3la[2] = res3la[3];
    res3la[3] = *result;
L200:
 
    d__1 = *abserr, d__2 = epmach * 5. * (( *result ) >= 0 ? ( *result ) : -( *result )) ;
    *abserr = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    return 0;
}  

 
  int ewset_(n, itol, rtol, atol, ycur, ewt)
integer *n, *itol;
doublereal *rtol, *atol, *ycur, *ewt;
{
     
    integer i__1;
    doublereal d__1;

     
    static integer i__;
    static doublereal atoli, rtoli;

 
 

 
 
 
 
 
 
 

     
    --ewt;
    --ycur;
    --rtol;
    --atol;

     
    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol >= 3) {
	    rtoli = rtol[i__];
	}
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	ewt[i__] = rtoli * (d__1 = ycur[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + atoli;
 
    }
    return 0;
 

}  

 
doublereal fnorm_(n, a, w)
integer *n;
doublereal *a, *w;
{
     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal ret_val, d__1, d__2;

     
    static integer i__, j;
    static doublereal an, sum;

 
 

 
 
 
 
 
 
 

     
    --w;
    a_dim1 = *n;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     
    an = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sum = 0.;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
 
	    sum += (d__1 = a[i__ + j * a_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / w[j];
	}
 
	d__1 = an, d__2 = sum * w[i__];
	an = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    }
    ret_val = an;
    return ret_val;
 

}  

 
  int intdy_(t, k, yh, nyh, dky, iflag)
doublereal *t;
integer *k;
doublereal *yh;
integer *nyh;
doublereal *dky;
integer *iflag;
{
     
    integer yh_dim1, yh_offset, i__1, i__2;

     
    double pow_di();

     
    static doublereal c__;
    static integer i__, j;
    static doublereal r__, s;
    static integer ic, jb, jj;
    static doublereal tp;
    static integer jb2, jj1, jp1;
    extern   int xerrwv_();
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --dky;

     
    *iflag = 0;
    if (*k < 0 || *k > (ls0001_._1) .nq) {
	goto L80;
    }
    tp = (ls0001_._1) .tn - (ls0001_._1) .hu * ((ls0001_._1) .uround * 100. + 1.);
    if ((*t - tp) * (*t - (ls0001_._1) .tn) > 0.) {
	goto L90;
    }

    s = (*t - (ls0001_._1) .tn) / (ls0001_._1) .h__;
    ic = 1;
    if (*k == 0) {
	goto L15;
    }
    jj1 = (ls0001_._1) .l - *k;
    i__1 = (ls0001_._1) .nq;
    for (jj = jj1; jj <= i__1; ++jj) {
 
	ic *= jj;
    }
L15:
    c__ = (doublereal) ic;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dky[i__] = c__ * yh[i__ + (ls0001_._1) .l * yh_dim1];
    }
    if (*k == (ls0001_._1) .nq) {
	goto L55;
    }
    jb2 = (ls0001_._1) .nq - *k;
    i__1 = jb2;
    for (jb = 1; jb <= i__1; ++jb) {
	j = (ls0001_._1) .nq - jb;
	jp1 = j + 1;
	ic = 1;
	if (*k == 0) {
	    goto L35;
	}
	jj1 = jp1 - *k;
	i__2 = j;
	for (jj = jj1; jj <= i__2; ++jj) {
 
	    ic *= jj;
	}
L35:
	c__ = (doublereal) ic;
	i__2 = (ls0001_._1) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    dky[i__] = c__ * yh[i__ + jp1 * yh_dim1] + s * dky[i__];
	}
 
    }
    if (*k == 0) {
	return 0;
    }
L55:
    i__1 = -(*k);
    r__ = pow_di(& (ls0001_._1) .h__, &i__1);
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dky[i__] = r__ * dky[i__];
    }
    return 0;

L80:
    xerrwv_("intdy--  k (=i1) illegal      ", &c__30, &c__51, &c__1, &c__1, k,
	     &c__0, &c__0, &c_b61, &c_b61, 30L);
    *iflag = -1;
    return 0;
L90:
    xerrwv_("intdy--  t (=r1) illegal      ", &c__30, &c__52, &c__1, &c__0, &
	    c__0, &c__0, &c__1, t, &c_b61, 30L);
    xerrwv_("      t n est pas entre tcur - hu (= r1) et tcur (=r2)", &c__60, 
	    &c__52, &c__1, &c__0, &c__0, &c__0, &c__2, &tp, & (ls0001_._1) .tn, 54L)
	    ;
    *iflag = -2;
    return 0;
 

}  

  int lsdisc_(f, neq, y, t, tout, rwork, lrw, istate)
  int (*f) ();
integer *neq;
doublereal *y, *t, *tout, *rwork;
integer *lrw, *istate;
{
     
    integer i__1;

     
      int s_copy();

     

    static integer j;
    extern   int dcopy_(), error_();
    static integer itout, it;
    static doublereal tt;

 
     
    --y;
    --rwork;

     
    it = (integer) (*t);
    itout = (integer) (*tout);
    ierode_ .iero = 0;
    if (itout < it) {
	s_copy(cha1_ .buf, "ode discrete : a requested k is smaller  than initial one", 4096L, 57L);
	error_(&c__999);
	return 0;
    } else if (itout == it) {
	*istate = 2;
	return 0;
    } else {
	i__1 = itout - 1;
	for (j = it; j <= i__1; ++j) {
	    tt = (doublereal) j;
	    (*f)(neq, &tt, &y[1], &rwork[1]);
	    if (ierode_ .iero > 0) {
		return 0;
	    }
	    dcopy_(neq, &rwork[1], &c__1, &y[1], &c__1);
 
	}
	*t = *tout;
	*istate = 2;
	return 0;
    }
}  




  int lsoda_(f, neq, y, t, tout, itol, rtol, atol, itask, 
	istate, iopt, rwork, lrw, iwork, liw, jac, jt)
  int (*f) ();
integer *neq;
doublereal *y, *t, *tout;
integer *itol;
doublereal *rtol, *atol;
integer *itask, *istate, *iopt;
doublereal *rwork;
integer *lrw, *iwork, *liw;
  int (*jac) ();
integer *jt;
{
     

    static integer mord[2] = { 12,5 };
    static integer mxstp0 = 500;
    static integer mxhnl0 = 10;

     
    integer i__1;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    extern   int prja_();
    static doublereal hmax;
    static logical ihit;
    static doublereal ewti, size;
    static integer len1c, len1n, len1s, i__, iflag;
    static doublereal atoli;
    static integer leniw, lenwm;
    extern   int stoda_();
    static integer imxer;
    static doublereal tcrit;
    static integer lenrw;
    static doublereal h0;
    static integer i1, i2;
    static doublereal rtoli, tdist, tolsf;
    extern   int ewset_();
    static doublereal tnext;
    extern   int intdy_();
    static doublereal w0;
    extern   int solsy_();
    extern doublereal dlamch_();
    static integer ml;
    static doublereal rh;
    static integer mu;
    static doublereal tp;
    static integer leniwc, lenrwc, lf0, lenrwn, lenrws;
    extern doublereal vmnorm_();
    extern   int xerrwv_();
    static doublereal big;
    static integer kgo;
    static doublereal ayi, hmx, tol, sum;
    static integer len1, len2;
     
    --neq;
    --y;
    --rtol;
    --atol;
    --rwork;
    --iwork;
    ierode_ .iero = 0;
    if (*istate < 1 || *istate > 3) {
	goto L601;
    }
    if (*itask < 1 || *itask > 5) {
	goto L602;
    }
    if (*istate == 1) {
	goto L10;
    }
    if ((ls0001_._2) .init == 0) {
	goto L603;
    }
    if (*istate == 2) {
	goto L200;
    }
    goto L20;
L10:
    (ls0001_._2) .init = 0;
    if (*tout == *t) {
	goto L430;
    }
L20:
    (ls0001_._2) .ntrep = 0;
 

 
 
 
 

 
 
 

    if (neq[1] <= 0) {
	goto L604;
    }
    if (*istate == 1) {
	goto L25;
    }
    if (neq[1] > (ls0001_._2) .n) {
	goto L605;
    }
L25:
    (ls0001_._2) .n = neq[1];
    if (*itol < 1 || *itol > 4) {
	goto L606;
    }
    if (*iopt < 0 || *iopt > 1) {
	goto L607;
    }
    if (*jt == 3 || *jt < 1 || *jt > 5) {
	goto L608;
    }
    (lsa001_._1) .jtyp = *jt;
    if (*jt <= 2) {
	goto L30;
    }
    ml = iwork[1];
    mu = iwork[2];
    if (ml < 0 || ml >= (ls0001_._2) .n) {
	goto L609;
    }
    if (mu < 0 || mu >= (ls0001_._2) .n) {
	goto L610;
    }
L30:
 

    if (*iopt == 1) {
	goto L40;
    }
    (lsa001_._1) .ixpr = 0;
    (ls0001_._2) .mxstep = mxstp0;
    (ls0001_._2) .mxhnil = mxhnl0;
    (ls0001_._2) .hmxi = 0.;
    (ls0001_._2) .hmin = 0.;
    if (*istate != 1) {
	goto L60;
    }
    h0 = 0.;
    (lsa001_._1) .mxordn = mord[0];
    (lsa001_._1) .mxords = mord[1];
    goto L60;
L40:
    (lsa001_._1) .ixpr = iwork[5];
    if ((lsa001_._1) .ixpr < 0 || (lsa001_._1) .ixpr > 1) {
	goto L611;
    }
    (ls0001_._2) .mxstep = iwork[6];
    if ((ls0001_._2) .mxstep < 0) {
	goto L612;
    }
    if ((ls0001_._2) .mxstep == 0) {
	(ls0001_._2) .mxstep = mxstp0;
    }
    (ls0001_._2) .mxhnil = iwork[7];
    if ((ls0001_._2) .mxhnil < 0) {
	goto L613;
    }
    if ((ls0001_._2) .mxhnil == 0) {
	(ls0001_._2) .mxhnil = mxhnl0;
    }
    if (*istate != 1) {
	goto L50;
    }
    h0 = rwork[5];
    (lsa001_._1) .mxordn = iwork[8];
    if ((lsa001_._1) .mxordn < 0) {
	goto L628;
    }
    if ((lsa001_._1) .mxordn == 0) {
	(lsa001_._1) .mxordn = 100;
    }
    (lsa001_._1) .mxordn = (( (lsa001_._1) .mxordn ) <= ( mord[0] ) ? ( (lsa001_._1) .mxordn ) : ( mord[0] )) ;
    (lsa001_._1) .mxords = iwork[9];
    if ((lsa001_._1) .mxords < 0) {
	goto L629;
    }
    if ((lsa001_._1) .mxords == 0) {
	(lsa001_._1) .mxords = 100;
    }
    (lsa001_._1) .mxords = (( (lsa001_._1) .mxords ) <= ( mord[1] ) ? ( (lsa001_._1) .mxords ) : ( mord[1] )) ;
    if ((*tout - *t) * h0 < 0.) {
	goto L614;
    }
L50:
    hmax = rwork[6];
    if (hmax < 0.) {
	goto L615;
    }
    (ls0001_._2) .hmxi = 0.;
    if (hmax > 0.) {
	(ls0001_._2) .hmxi = 1. / hmax;
    }
    (ls0001_._2) .hmin = rwork[7];
    if ((ls0001_._2) .hmin < 0.) {
	goto L616;
    }
 

 
 
 
 
 
 
 
 
 
 
 
 

L60:
    if (*istate == 1) {
	(ls0001_._2) .meth = 1;
    }
    if (*istate == 1) {
	(ls0001_._2) .nyh = (ls0001_._2) .n;
    }
    (ls0001_._2) .lyh = 21;
    len1n = ((lsa001_._1) .mxordn + 1) * (ls0001_._2) .nyh + 20;
    len1s = ((lsa001_._1) .mxords + 1) * (ls0001_._2) .nyh + 20;
    (ls0001_._2) .lwm = len1s + 1;
    if (*jt <= 2) {
	lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2;
    }
    if (*jt >= 4) {
	lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2;
    }
    len1s += lenwm;
    len1c = len1n;
    if ((ls0001_._2) .meth == 2) {
	len1c = len1s;
    }
    len1 = (( len1n ) >= ( len1s ) ? ( len1n ) : ( len1s )) ;
    len2 = (ls0001_._2) .n * 3;
    lenrw = len1 + len2;
    lenrwn = len1n + len2;
    lenrws = len1s + len2;
    lenrwc = len1c + len2;
    iwork[17] = lenrw;
    (ls0001_._2) .liwm = 1;
    leniw = (ls0001_._2) .n + 20;
    leniwc = 20;
    if ((ls0001_._2) .meth == 2) {
	leniwc = leniw;
    }
    iwork[18] = leniw;
    if (*istate == 1 && *lrw < lenrwc) {
	goto L617;
    }
    if (*istate == 1 && *liw < leniwc) {
	goto L618;
    }
    if (*istate == 3 && *lrw < lenrwc) {
	goto L550;
    }
    if (*istate == 3 && *liw < leniwc) {
	goto L555;
    }
    (ls0001_._2) .lewt = len1 + 1;
    (lsa001_._1) .insufr = 0;
    if (*lrw >= lenrw) {
	goto L65;
    }
    (lsa001_._1) .insufr = 2;
    (ls0001_._2) .lewt = len1c + 1;
    xerrwv_("lsoda-- attention size of  rwork now suffisent", &c__60, &c__103,
	     &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L);
    xerrwv_("but may become too small : integration continues", &c__60, &
	    c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L);
    xerrwv_("required size is i1 given size is i2", &c__50, &c__103, &c__1, &
	    c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 36L);
L65:
    (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n;
    (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n;
    (lsa001_._1) .insufi = 0;
    if (*liw >= leniw) {
	goto L70;
    }
    (lsa001_._1) .insufi = 2;
    xerrwv_("lsoda-- size for  iwork now sufficient", &c__60, &c__104, &c__1, 
	    &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 38L);
    xerrwv_("may become too small.  integration continues", &c__60, &c__104, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 44L);
    xerrwv_("required size is i1, given size is i2", &c__50, &c__104, &c__1, &
	    c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 37L);
L70:
 

    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol >= 3) {
	    rtoli = rtol[i__];
	}
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	if (rtoli < 0.) {
	    goto L619;
	}
	if (atoli < 0.) {
	    goto L620;
	}
 
    }
    if (*istate == 1) {
	goto L100;
    }
 

    (ls0001_._2) .jstart = -1;
    if ((ls0001_._2) .n == (ls0001_._2) .nyh) {
	goto L200;
    }
 

    i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh;
    i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1;
    if (i1 > i2) {
	goto L200;
    }
    i__1 = i2;
    for (i__ = i1; i__ <= i__1; ++i__) {
 
	rwork[i__] = 0.;
    }
    goto L200;
 

 
 
 
 
 
 

L100:
    (ls0001_._2) .uround = dlamch_("p", 1L);
    (ls0001_._2) .tn = *t;
    (lsa001_._1) .tsw = *t;
    (ls0001_._2) .maxord = (lsa001_._1) .mxordn;
    if (*itask != 4 && *itask != 5) {
	goto L110;
    }
    tcrit = rwork[1];
    if ((tcrit - *tout) * (*tout - *t) < 0.) {
	goto L625;
    }
    if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) {
	h0 = tcrit - *t;
    }
L110:
    (ls0001_._2) .jstart = 0;
    (ls0001_._2) .nhnil = 0;
    (ls0001_._2) .nst = 0;
    (ls0001_._2) .nje = 0;
    (ls0001_._2) .nslast = 0;
    (ls0001_._2) .hu = 0.;
    (ls0001_._2) .nqu = 0;
    (lsa001_._1) .mused = 0;
    (ls0001_._2) .miter = 0;
    (ls0001_._2) .ccmax = .3;
    (ls0001_._2) .maxcor = 3;
    (ls0001_._2) .msbp = 20;
    (ls0001_._2) .mxncf = 10;
 

    lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh;
    (*f)(&neq[1], t, &y[1], &rwork[lf0]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    (ls0001_._2) .nfe = 1;
 

    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__];
    }
 

    (ls0001_._2) .nq = 1;
    (ls0001_._2) .h__ = 1.;
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L621;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
 

 
 
 
 
 
 
 

 

 
 
 
 
 
 
 
 

    if (h0 != 0.) {
	goto L180;
    }
    tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
    d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if (tdist < (ls0001_._2) .uround * 2. * w0) {
	goto L622;
    }
    tol = rtol[1];
    if (*itol <= 2) {
	goto L140;
    }
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = tol, d__2 = rtol[i__];
	tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
L140:
    if (tol > 0.) {
	goto L160;
    }
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (ayi != 0.) {
 
	    d__1 = tol, d__2 = atoli / ayi;
	    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	}
 
    }
L160:
 
    d__1 = tol, d__2 = (ls0001_._2) .uround * 100.;
    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ;
    sum = vmnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]);
 
    d__1 = sum;
    sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1);
    h0 = 1. / sqrt(sum);
    h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ;
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);
 

L180:
    rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 ))  * (ls0001_._2) .hmxi;
    if (rh > 1.) {
	h0 /= rh;
    }
 

    (ls0001_._2) .h__ = h0;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1];
    }
    goto L270;
 

 
 
 
 

L200:
    (ls0001_._2) .nslast = (ls0001_._2) .nst;
    switch ((int)*itask) {
	case 1:  goto L210;
	case 2:  goto L250;
	case 3:  goto L220;
	case 4:  goto L230;
	case 5:  goto L240;
    }
L210:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L220:
    tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.);
    if ((tp - *tout) * (ls0001_._2) .h__ > 0.) {
	goto L623;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    *t = (ls0001_._2) .tn;
    goto L400;
L230:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
    if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L625;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L245;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L240:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
L245:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	*t = tcrit;
    }
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
 
 
    if (*istate == 2 && (ls0001_._2) .jstart != -1) {
	(ls0001_._2) .jstart = -2;
    }
 

 
 
 

 

 
 
 
 

L250:
    if ((ls0001_._2) .meth == (lsa001_._1) .mused) {
	goto L255;
    }
    if ((lsa001_._1) .insufr == 1) {
	goto L550;
    }
    if ((lsa001_._1) .insufi == 1) {
	goto L555;
    }
L255:
    if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) {
	goto L500;
    }
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L510;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
L270:
    tolsf = (ls0001_._2) .uround * vmnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    if (tolsf <= .01) {
	goto L280;
    }
    tolsf *= 200.;
    if ((ls0001_._2) .nst == 0) {
	goto L626;
    }
    goto L520;
L280:
    if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) {
	goto L290;
    }
    ++ (ls0001_._2) .nhnil;
    if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsoda--  caution... t (=r1) and h (=r2) are", &c__50, &c__101, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 43L);
    xerrwv_("     such that t + h = t at next step", &c__60, &c__101, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L);
    xerrwv_("      (h = pas). integration continues", &c__50, &c__101, &c__1, 
	    &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 38L);
    if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsoda--  previous message precedent given i1 times", &c__50, &
	    c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("     will no more be repeated", &c__50, &c__102, &c__1, &c__1, &
	    (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 29L);
L290:
 

 

 

    stoda_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[
	    (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], &
	    rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm]
	    , f, jac, prja_, solsy_);
    if (ierode_ .iero > 0) {
	return 0;
    }
    kgo = 1 - (ls0001_._2) .kflag;
    switch ((int)kgo) {
	case 1:  goto L300;
	case 2:  goto L530;
	case 3:  goto L540;
    }
 

 
 
 
 
 
 
 
 

L300:
    (ls0001_._2) .init = 1;
    if ((ls0001_._2) .meth == (lsa001_._1) .mused) {
	goto L310;
    }
    (lsa001_._1) .tsw = (ls0001_._2) .tn;
    (ls0001_._2) .maxord = (lsa001_._1) .mxordn;
    if ((ls0001_._2) .meth == 2) {
	(ls0001_._2) .maxord = (lsa001_._1) .mxords;
    }
    if ((ls0001_._2) .meth == 2) {
	rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround);
    }
    (lsa001_._1) .insufr = (( (lsa001_._1) .insufr ) <= ( 1 ) ? ( (lsa001_._1) .insufr ) : ( 1 )) ;
    (lsa001_._1) .insufi = (( (lsa001_._1) .insufi ) <= ( 1 ) ? ( (lsa001_._1) .insufi ) : ( 1 )) ;
    (ls0001_._2) .jstart = -1;
    if ((lsa001_._1) .ixpr == 0) {
	goto L310;
    }
    if ((ls0001_._2) .meth == 2) {
	xerrwv_("lsoda-- using stiff method  ", &c__60, &c__105, &c__1, &c__0,
		 &c__0, &c__0, &c__0, &c_b61, &c_b61, 28L);
    }
    if ((ls0001_._2) .meth == 1) {
	xerrwv_("lsoda-- using adams formulas (non stiff)", &c__60, &c__106, &
		c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L);
    }
    xerrwv_("     a t = r1, trial with step h = r2,  step nst = i1 ", &c__60, 
	    &c__107, &c__1, &c__1, & (ls0001_._2) .nst, &c__0, &c__2, & (ls0001_._2) .tn, 
	    & (ls0001_._2) .h__, 54L);
L310:
    switch ((int)*itask) {
	case 1:  goto L320;
	case 2:  goto L400;
	case 3:  goto L330;
	case 4:  goto L340;
	case 5:  goto L350;
    }
 

L320:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
 

L330:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) {
	goto L400;
    }
    goto L250;
 

L340:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L345;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
L345:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
 
 
    if ((ls0001_._2) .jstart != -1) {
	(ls0001_._2) .jstart = -2;
    }
    goto L250;
 

L350:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
 

 
 
 
 
 
 
 
 

L400:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    if (*itask != 4 && *itask != 5) {
	goto L420;
    }
    if (ihit) {
	*t = tcrit;
    }
L420:
    *istate = 2;
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    rwork[15] = (lsa001_._1) .tsw;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    iwork[19] = (lsa001_._1) .mused;
    iwork[20] = (ls0001_._2) .meth;
    return 0;

L430:
    ++ (ls0001_._2) .ntrep;
    if ((ls0001_._2) .ntrep < 5) {
	return 0;
    }
    xerrwv_("lsoda--  repeated calls with istate = 1 and tout = t (=r1)  ", &
	    c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L)
	    ;
    goto L800;
 

 
 
 
 

 
 
 
 

 

L500:
    xerrwv_("lsoda--  at t (=r1), mxstep (=i1) steps   ", &c__50, &c__201, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L);
    xerrwv_("needed before reaching totu", &c__50, &c__201, &c__1, &c__1, &
	    (ls0001_._2) .mxstep, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 27L);
    *istate = -1;
    goto L580;
 

L510:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsoda--  at t (=r1), ewt(i1) is r2 .le. 0.", &c__50, &c__202, &
	    c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 42L);
    *istate = -6;
    goto L580;
 

L520:
    xerrwv_("lsoda--  a t (=r1),  too much precision required", &c__50, &
	    c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L);
    xerrwv_(" with respect to epsilon  tolsf (=r2) ", &c__50, &c__203, &c__1, 
	    &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 38L);
    rwork[14] = tolsf;
    *istate = -2;
    goto L580;
 

L530:
    xerrwv_("lsoda--  at t(=r1) and for step h(=r2), error", &c__50, &c__204, 
	    &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 45L);
    xerrwv_("      failed with abs(h) = hmin", &c__50, &c__204, &c__1, &c__0, 
	    &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 31L);
    *istate = -4;
    goto L560;
 

L540:
    xerrwv_("lsoda--  at t (=r1) and step h (=r2), the", &c__50, &c__205, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 41L);
    xerrwv_("   corrector does not converge ", &c__50, &c__205, &c__1, &c__0, 
	    &c__0, &c__0, &c__0, &c_b61, &c_b61, 31L);
    xerrwv_("      with abs(h) = hmin   ", &c__30, &c__205, &c__1, &c__0, &
	    c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 27L);
    *istate = -5;
    goto L560;
 

L550:
    xerrwv_("lsoda--  a t(=r1), rwork too small", &c__50, &c__206, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L);
    xerrwv_("        to continue. integration ok.", &c__60, &c__206, &c__1, &
	    c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 36L);
    *istate = -7;
    goto L580;
 

L555:
    xerrwv_("lsoda--  at t(=r1)  iwork too small", &c__50, &c__207, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 35L);
    xerrwv_("       to continue.  integration ok.", &c__60, &c__207, &c__1, &
	    c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 36L);
    *istate = -7;
    goto L580;
 

L560:
    big = 0.;
    imxer = 1;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + 
		(ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (big >= size) {
	    goto L570;
	}
	big = size;
	imxer = i__;
L570:
	;
    }
    iwork[16] = imxer;
 

L580:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    rwork[15] = (lsa001_._1) .tsw;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    iwork[19] = (lsa001_._1) .mused;
    iwork[20] = (ls0001_._2) .meth;
    return 0;
 

 
 
 
 
 
 
 

L601:
    xerrwv_("lsoda--  istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, 
	    istate, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L602:
    xerrwv_("lsoda--  itask (=i1) illegal  ", &c__30, &c__2, &c__1, &c__1, 
	    itask, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L603:
    xerrwv_("lsoda--  istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 23L);
    goto L700;
L604:
    xerrwv_("lsoda--  neq (=i1) .lt. 1     ", &c__30, &c__4, &c__1, &c__1, &
	    neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L605:
    xerrwv_("lsoda--  istate and neq  increased from i1 to i2", &c__50, &c__5,
	     &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 48L);
    goto L700;
L606:
    xerrwv_("lsoda--  itol (=i1) illegal   ", &c__30, &c__6, &c__1, &c__1, 
	    itol, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L607:
    xerrwv_("lsoda--  iopt (=i1) illegal   ", &c__30, &c__7, &c__1, &c__1, 
	    iopt, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L608:
    xerrwv_("lsoda--  jt (=i1) illegal     ", &c__30, &c__8, &c__1, &c__1, jt,
	     &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L609:
    xerrwv_("lsoda--  ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L610:
    xerrwv_("lsoda--  mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L611:
    xerrwv_("lsoda--  ixpr (=i1) illegal   ", &c__30, &c__11, &c__1, &c__1, &
	    (lsa001_._1) .ixpr, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L612:
    xerrwv_("lsoda--  mxstep (=i1) .lt. 0  ", &c__30, &c__12, &c__1, &c__1, &
	    (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L613:
    xerrwv_("lsoda--  mxhnil (=i1) .lt. 0  ", &c__30, &c__13, &c__1, &c__1, &
	    (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L614:
    xerrwv_("lsoda--  tout (=r1)  .gt.  t (=r2)      ", &c__40, &c__14, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    xerrwv_("      h0 (=r1) gives direction", &c__50, &c__14, &c__1, &c__0, &
	    c__0, &c__0, &c__1, &h0, &c_b61, 30L);
    goto L700;
L615:
    xerrwv_("lsoda--  hmax (=r1) .lt. 0.0  ", &c__30, &c__15, &c__1, &c__0, &
	    c__0, &c__0, &c__1, &hmax, &c_b61, 30L);
    goto L700;
L616:
    xerrwv_("lsoda--  hmin (=r1) .lt. 0.0  ", &c__30, &c__16, &c__1, &c__0, &
	    c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L);
    goto L700;
L617:
    xerrwv_("lsoda-- required size for iwork (i1) larger than i2", &c__60, &
	    c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 51L);
    goto L700;
L618:
    xerrwv_("lsoda-- required size for iwork (=i1) larger than i2", &c__60, &
	    c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 52L);
    goto L700;
L619:
    xerrwv_("lsoda--  rtol(i1) is r1 .lt. 0.0        ", &c__40, &c__19, &c__1,
	     &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L);
    goto L700;
L620:
    xerrwv_("lsoda--  atol(i1) is r1 .lt. 0.0        ", &c__40, &c__20, &c__1,
	     &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L);
    goto L700;
L621:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsoda--  ewt(i1) is r1 .le. 0.0         ", &c__40, &c__21, &c__1,
	     &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 40L);
    goto L700;
L622:
    xerrwv_("lsoda--  tout (=r1) too close to t(=r2) to integrate", &c__60, &
	    c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 52L);
    goto L700;
L623:
    xerrwv_("lsoda--  itask = i1 and tout (=r1) .gt. tcur - hu (= r2)  ", &
	    c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 58L);
    goto L700;
L624:
    xerrwv_("lsoda--  itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2)   ", &
	    c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, &
	    (ls0001_._2) .tn, 58L);
    goto L700;
L625:
    xerrwv_("lsoda--  itask = 4 or 5 and tcrit (=r1)  .gt.  tout (=r2)", &
	    c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 
	    57L);
    goto L700;
L626:
    xerrwv_("lsoda-- precision asked ", &c__50, &c__26, &c__1, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 24L);
    xerrwv_("too accurate. tolsf (=r1)", &c__60, &c__26, &c__1, &c__0, &c__0, 
	    &c__0, &c__1, &tolsf, &c_b61, 25L);
    rwork[14] = tolsf;
    goto L700;
L627:
    xerrwv_("lsoda--  problems due to intdy. itask=i1,tout=r1", &c__50, &
	    c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 48L);
    goto L700;
L628:
    xerrwv_("lsoda--  mxordn (=i1) .lt. 0  ", &c__30, &c__28, &c__1, &c__1, &
	    (lsa001_._1) .mxordn, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L629:
    xerrwv_("lsoda--  mxords (=i1) .lt. 0  ", &c__30, &c__29, &c__1, &c__1, &
	    (lsa001_._1) .mxords, &c__0, &c__0, &c_b61, &c_b61, 30L);

L700:
    if ((ls0001_._2) .illin == 5) {
	goto L710;
    }
    ++ (ls0001_._2) .illin;
    *istate = -3;
    return 0;
L710:
    xerrwv_("lsoda--  incorrect input", &c__50, &c__302, &c__1, &c__0, &c__0, 
	    &c__0, &c__0, &c_b61, &c_b61, 24L);

L800:
    xerrwv_("lsoda-- infinite loop? ", &c__50, &c__303, &c__2, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 23L);
    return 0;
 

}  

  int lsodar_(f, neq, y, t, tout, itol, rtol, atol, itask, 
	istate, iopt, rwork, lrw, iwork, liw, jac, jt, g, ng, jroot)
  int (*f) ();
integer *neq;
doublereal *y, *t, *tout;
integer *itol;
doublereal *rtol, *atol;
integer *itask, *istate, *iopt;
doublereal *rwork;
integer *lrw, *iwork, *liw;
  int (*jac) ();
integer *jt;
  int (*g) ();
integer *ng, *jroot;
{
     

    static integer mord[2] = { 12,5 };
    static integer mxstp0 = 500;
    static integer mxhnl0 = 10;

     
    integer i__1;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    extern   int prja_();
    static doublereal hmax;
    static integer irfp;
    static logical ihit;
    static doublereal ewti, size;
    static integer len1c, len1n, len1s, i__, iflag;
    extern   int rchek_();
    static doublereal atoli;
    static integer leniw, lenwm, lenyh, imxer;
    static doublereal tcrit;
    extern   int dcopy_();
    static integer lenrw, i1, i2;
    static doublereal h0, rtoli, tdist, tnext, tolsf, w0;
    extern   int solsy_();
    extern   int ewset_(), intdy_(), stoda_();
    extern doublereal dlamch_();
    static integer ml;
    static doublereal rh;
    static integer mu;
    static doublereal tp;
    static integer leniwc, lenrwc, lf0, lenrwn, lenrws, lyhnew;
    extern doublereal vmnorm_();
    extern   int xerrwv_();
    static doublereal big;
    static integer kgo;
    static doublereal ayi, hmx;
    static integer irt;
    static doublereal tol, sum;
    static integer len1, len2;
    --neq;
    --y;
    --rtol;
    --atol;
    --rwork;
    --iwork;
    --jroot;
    if (*istate < 1 || *istate > 3) {
	goto L601;
    }
    if (*itask < 1 || *itask > 5) {
	goto L602;
    }
    (lsr001_._1) .itaskc = *itask;
    if (*istate == 1) {
	goto L10;
    }
    if ((ls0001_._2) .init == 0) {
	goto L603;
    }
    if (*istate == 2) {
	goto L200;
    }
    goto L20;
L10:
    (ls0001_._2) .init = 0;
    if (*tout == *t) {
	goto L430;
    }
L20:
    (ls0001_._2) .ntrep = 0;
 

 
 
 
 

 
 
 

    if (neq[1] <= 0) {
	goto L604;
    }
    if (*istate == 1) {
	goto L25;
    }
    if (neq[1] > (ls0001_._2) .n) {
	goto L605;
    }
L25:
    (ls0001_._2) .n = neq[1];
    if (*itol < 1 || *itol > 4) {
	goto L606;
    }
    if (*iopt < 0 || *iopt > 1) {
	goto L607;
    }
    if (*jt == 3 || *jt < 1 || *jt > 5) {
	goto L608;
    }
    (lsa001_._1) .jtyp = *jt;
    if (*jt <= 2) {
	goto L30;
    }
    ml = iwork[1];
    mu = iwork[2];
    if (ml < 0 || ml >= (ls0001_._2) .n) {
	goto L609;
    }
    if (mu < 0 || mu >= (ls0001_._2) .n) {
	goto L610;
    }
L30:
    if (*ng < 0) {
	goto L630;
    }
    if (*istate == 1) {
	goto L35;
    }
    if ((lsr001_._1) .irfnd == 0 && *ng != (lsr001_._1) .ngc) {
	goto L631;
    }
L35:
    (lsr001_._1) .ngc = *ng;
 

    if (*iopt == 1) {
	goto L40;
    }
    (lsa001_._1) .ixpr = 0;
    (ls0001_._2) .mxstep = mxstp0;
    (ls0001_._2) .mxhnil = mxhnl0;
    (ls0001_._2) .hmxi = 0.;
    (ls0001_._2) .hmin = 0.;
    if (*istate != 1) {
	goto L60;
    }
    h0 = 0.;
    (lsa001_._1) .mxordn = mord[0];
    (lsa001_._1) .mxords = mord[1];
    goto L60;
L40:
    (lsa001_._1) .ixpr = iwork[5];
    if ((lsa001_._1) .ixpr < 0 || (lsa001_._1) .ixpr > 1) {
	goto L611;
    }
    (ls0001_._2) .mxstep = iwork[6];
    if ((ls0001_._2) .mxstep < 0) {
	goto L612;
    }
    if ((ls0001_._2) .mxstep == 0) {
	(ls0001_._2) .mxstep = mxstp0;
    }
    (ls0001_._2) .mxhnil = iwork[7];
    if ((ls0001_._2) .mxhnil < 0) {
	goto L613;
    }
    if ((ls0001_._2) .mxhnil == 0) {
	(ls0001_._2) .mxhnil = mxhnl0;
    }
    if (*istate != 1) {
	goto L50;
    }
    h0 = rwork[5];
    (lsa001_._1) .mxordn = iwork[8];
    if ((lsa001_._1) .mxordn < 0) {
	goto L628;
    }
    if ((lsa001_._1) .mxordn == 0) {
	(lsa001_._1) .mxordn = 100;
    }
    (lsa001_._1) .mxordn = (( (lsa001_._1) .mxordn ) <= ( mord[0] ) ? ( (lsa001_._1) .mxordn ) : ( mord[0] )) ;
    (lsa001_._1) .mxords = iwork[9];
    if ((lsa001_._1) .mxords < 0) {
	goto L629;
    }
    if ((lsa001_._1) .mxords == 0) {
	(lsa001_._1) .mxords = 100;
    }
    (lsa001_._1) .mxords = (( (lsa001_._1) .mxords ) <= ( mord[1] ) ? ( (lsa001_._1) .mxords ) : ( mord[1] )) ;
    if ((*tout - *t) * h0 < 0.) {
	goto L614;
    }
L50:
    hmax = rwork[6];
    if (hmax < 0.) {
	goto L615;
    }
    (ls0001_._2) .hmxi = 0.;
    if (hmax > 0.) {
	(ls0001_._2) .hmxi = 1. / hmax;
    }
    (ls0001_._2) .hmin = rwork[7];
    if ((ls0001_._2) .hmin < 0.) {
	goto L616;
    }
 

 
 
 
 
 
 
 
 
 
 
 
 
 

L60:
    if (*istate == 1) {
	(ls0001_._2) .meth = 1;
    }
    if (*istate == 1) {
	(ls0001_._2) .nyh = (ls0001_._2) .n;
    }
    (lsr001_._1) .lg0 = 21;
    (lsr001_._1) .lg1 = (lsr001_._1) .lg0 + *ng;
    (lsr001_._1) .lgx = (lsr001_._1) .lg1 + *ng;
    lyhnew = (lsr001_._1) .lgx + *ng;
    if (*istate == 1) {
	(ls0001_._2) .lyh = lyhnew;
    }
    if (lyhnew == (ls0001_._2) .lyh) {
	goto L62;
    }
 

    lenyh = (ls0001_._2) .l * (ls0001_._2) .nyh;
    if (*lrw < lyhnew - 1 + lenyh) {
	goto L62;
    }
    i1 = 1;
    if (lyhnew > (ls0001_._2) .lyh) {
	i1 = -1;
    }
    dcopy_(&lenyh, &rwork[(ls0001_._2) .lyh], &i1, &rwork[lyhnew], &i1);
    (ls0001_._2) .lyh = lyhnew;
L62:
    len1n = lyhnew - 1 + ((lsa001_._1) .mxordn + 1) * (ls0001_._2) .nyh;
    len1s = lyhnew - 1 + ((lsa001_._1) .mxords + 1) * (ls0001_._2) .nyh;
    (ls0001_._2) .lwm = len1s + 1;
    if (*jt <= 2) {
	lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2;
    }
    if (*jt >= 4) {
	lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2;
    }
    len1s += lenwm;
    len1c = len1n;
    if ((ls0001_._2) .meth == 2) {
	len1c = len1s;
    }
    len1 = (( len1n ) >= ( len1s ) ? ( len1n ) : ( len1s )) ;
    len2 = (ls0001_._2) .n * 3;
    lenrw = len1 + len2;
    lenrwn = len1n + len2;
    lenrws = len1s + len2;
    lenrwc = len1c + len2;
    iwork[17] = lenrw;
    (ls0001_._2) .liwm = 1;
    leniw = (ls0001_._2) .n + 20;
    leniwc = 20;
    if ((ls0001_._2) .meth == 2) {
	leniwc = leniw;
    }
    iwork[18] = leniw;
    if (*istate == 1 && *lrw < lenrwc) {
	goto L617;
    }
    if (*istate == 1 && *liw < leniwc) {
	goto L618;
    }
    if (*istate == 3 && *lrw < lenrwc) {
	goto L550;
    }
    if (*istate == 3 && *liw < leniwc) {
	goto L555;
    }
    (ls0001_._2) .lewt = len1 + 1;
    (lsa001_._1) .insufr = 0;
    if (*lrw >= lenrw) {
	goto L65;
    }
    (lsa001_._1) .insufr = 2;
    (ls0001_._2) .lewt = len1c + 1;
    xerrwv_("lsodar-  warning.. rwork length is sufficient for now, but  ", &
	    c__60, &c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61,
	     60L);
    xerrwv_("      may not be later.  integration will proceed anyway.   ", &
	    c__60, &c__103, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61,
	     60L);
    xerrwv_("      length needed is lenrw = i1, while lrw = i2.", &c__50, &
	    c__103, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 50L);
L65:
    (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n;
    (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n;
    (lsa001_._1) .insufi = 0;
    if (*liw >= leniw) {
	goto L70;
    }
    (lsa001_._1) .insufi = 2;
    xerrwv_("lsodar-  warning.. iwork length is sufficient for now, but  ", &
	    c__60, &c__104, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61,
	     60L);
    xerrwv_("      may not be later.  integration will proceed anyway.   ", &
	    c__60, &c__104, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61,
	     60L);
    xerrwv_("      length needed is leniw = i1, while liw = i2.", &c__50, &
	    c__104, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 50L);
L70:
 

    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol >= 3) {
	    rtoli = rtol[i__];
	}
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	if (rtoli < 0.) {
	    goto L619;
	}
	if (atoli < 0.) {
	    goto L620;
	}
 
    }
    if (*istate == 1) {
	goto L100;
    }
 

    (ls0001_._2) .jstart = -1;
    if ((ls0001_._2) .n == (ls0001_._2) .nyh) {
	goto L200;
    }
 

    i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh;
    i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1;
    if (i1 > i2) {
	goto L200;
    }
    i__1 = i2;
    for (i__ = i1; i__ <= i__1; ++i__) {
 
	rwork[i__] = 0.;
    }
    goto L200;
 

 
 
 
 
 
 

L100:
    (ls0001_._2) .uround = dlamch_("p", 1L);
    (ls0001_._2) .tn = *t;
    (lsa001_._1) .tsw = *t;
    (ls0001_._2) .maxord = (lsa001_._1) .mxordn;
    if (*itask != 4 && *itask != 5) {
	goto L110;
    }
    tcrit = rwork[1];
    if ((tcrit - *tout) * (*tout - *t) < 0.) {
	goto L625;
    }
    if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) {
	h0 = tcrit - *t;
    }
L110:
    (ls0001_._2) .jstart = 0;
    (ls0001_._2) .nhnil = 0;
    (ls0001_._2) .nst = 0;
    (ls0001_._2) .nje = 0;
    (ls0001_._2) .nslast = 0;
    (ls0001_._2) .hu = 0.;
    (ls0001_._2) .nqu = 0;
    (lsa001_._1) .mused = 0;
    (ls0001_._2) .miter = 0;
    (ls0001_._2) .ccmax = .3;
    (ls0001_._2) .maxcor = 3;
    (ls0001_._2) .msbp = 20;
    (ls0001_._2) .mxncf = 10;
 

    lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh;
    (*f)(&neq[1], t, &y[1], &rwork[lf0]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    (ls0001_._2) .nfe = 1;
 

    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__];
    }
 

    (ls0001_._2) .nq = 1;
    (ls0001_._2) .h__ = 1.;
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L621;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
 

 
 
 
 
 
 
 

 

 
 
 
 
 
 
 
 

    if (h0 != 0.) {
	goto L180;
    }
    tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
    d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if (tdist < (ls0001_._2) .uround * 2. * w0) {
	goto L622;
    }
    tol = rtol[1];
    if (*itol <= 2) {
	goto L140;
    }
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = tol, d__2 = rtol[i__];
	tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
L140:
    if (tol > 0.) {
	goto L160;
    }
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (ayi != 0.) {
 
	    d__1 = tol, d__2 = atoli / ayi;
	    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	}
 
    }
L160:
 
    d__1 = tol, d__2 = (ls0001_._2) .uround * 100.;
    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ;
    sum = vmnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]);
 
    d__1 = sum;
    sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1);
    h0 = 1. / sqrt(sum);
    h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ;
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);
 

L180:
    rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 ))  * (ls0001_._2) .hmxi;
    if (rh > 1.) {
	h0 /= rh;
    }
 

    (ls0001_._2) .h__ = h0;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1];
    }

 

    (lsr001_._1) .irfnd = 0;
    (lsr001_._1) .toutc = *tout;
    if ((lsr001_._1) .ngc == 0) {
	goto L270;
    }
    rchek_(&c__1, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &
	    rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], &
	    jroot[1], &irt);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if (irt == 0) {
	goto L270;
    }
    goto L632;
 

 
 
 
 
 
 
 
 

L200:
    (ls0001_._2) .nslast = (ls0001_._2) .nst;

    irfp = (lsr001_._1) .irfnd;
    if ((lsr001_._1) .ngc == 0) {
	goto L205;
    }
    if (*itask == 1 || *itask == 4) {
	(lsr001_._1) .toutc = *tout;
    }
    rchek_(&c__2, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &
	    rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], &
	    jroot[1], &irt);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if (irt != 1) {
	goto L205;
    }
    (lsr001_._1) .irfnd = 1;
    *istate = 3;
    *t = (lsr001_._1) .t0;
    goto L425;
L205:
    (lsr001_._1) .irfnd = 0;
    if (irfp == 1 && (lsr001_._1) .tlast != (ls0001_._2) .tn && *itask == 2) {
	goto L400;
    }

    switch ((int)*itask) {
	case 1:  goto L210;
	case 2:  goto L250;
	case 3:  goto L220;
	case 4:  goto L230;
	case 5:  goto L240;
    }
L210:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L220:
    tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.);
    if ((tp - *tout) * (ls0001_._2) .h__ > 0.) {
	goto L623;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    *t = (ls0001_._2) .tn;
    goto L400;
L230:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
    if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L625;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L245;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L240:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
L245:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	*t = tcrit;
    }
    if (irfp == 1 && (lsr001_._1) .tlast != (ls0001_._2) .tn && *itask == 5) {
	goto L400;
    }
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
    if (*istate == 2) {
	(ls0001_._2) .jstart = -2;
    }
 

 
 
 

 

 
 
 
 

L250:
    if ((ls0001_._2) .meth == (lsa001_._1) .mused) {
	goto L255;
    }
    if ((lsa001_._1) .insufr == 1) {
	goto L550;
    }
    if ((lsa001_._1) .insufi == 1) {
	goto L555;
    }
L255:
    if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) {
	goto L500;
    }
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L510;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
L270:
    tolsf = (ls0001_._2) .uround * vmnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    if (tolsf <= .01) {
	goto L280;
    }
    tolsf *= 200.;
    if ((ls0001_._2) .nst == 0) {
	goto L626;
    }
    goto L520;
L280:
    if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) {
	goto L290;
    }
    ++ (ls0001_._2) .nhnil;
    if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsodar-  warning..internal t (=r1) and h (=r2) are", &c__50, &
	    c__101, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      such that in the machine, t + h = t on the next step ", &
	    c__60, &c__101, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61,
	     59L);
    xerrwv_("      (h = step size). solver will continue anyway", &c__50, &
	    c__101, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &
	    (ls0001_._2) .h__, 50L);
    if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("sodar-  above warning has been issued i1 times.  ", &c__50, &
	    c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
    xerrwv_("     it will not be issued again for this problem", &c__50, &
	    c__102, &c__1, &c__1, & (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &
	    c_b61, 49L);
L290:
 

 

 

    stoda_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[
	    (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], &
	    rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm]
	    , f, jac, prja_, solsy_);
    if (ierode_ .iero > 0) {
	return 0;
    }
    kgo = 1 - (ls0001_._2) .kflag;
    switch ((int)kgo) {
	case 1:  goto L300;
	case 2:  goto L530;
	case 3:  goto L540;
    }
 

 
 
 
 
 
 
 
 
 

L300:
    (ls0001_._2) .init = 1;
    if ((ls0001_._2) .meth == (lsa001_._1) .mused) {
	goto L310;
    }
    (lsa001_._1) .tsw = (ls0001_._2) .tn;
    (ls0001_._2) .maxord = (lsa001_._1) .mxordn;
    if ((ls0001_._2) .meth == 2) {
	(ls0001_._2) .maxord = (lsa001_._1) .mxords;
    }
    if ((ls0001_._2) .meth == 2) {
	rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround);
    }
    (lsa001_._1) .insufr = (( (lsa001_._1) .insufr ) <= ( 1 ) ? ( (lsa001_._1) .insufr ) : ( 1 )) ;
    (lsa001_._1) .insufi = (( (lsa001_._1) .insufi ) <= ( 1 ) ? ( (lsa001_._1) .insufi ) : ( 1 )) ;
    (ls0001_._2) .jstart = -1;
    if ((lsa001_._1) .ixpr == 0) {
	goto L310;
    }
    if ((ls0001_._2) .meth == 2) {
	xerrwv_("lsodar- a switch to the bdf (stiff) method has occurred     "
		, &c__60, &c__105, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, 
		&c_b61, 60L);
    }
    if ((ls0001_._2) .meth == 1) {
	xerrwv_("lsodar- a switch to the adams (nonstiff) method has occurred"
		, &c__60, &c__106, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, 
		&c_b61, 60L);
    }
    xerrwv_("     at t = r1,  tentative step size h = r2,  step nst = i1 ", &
	    c__60, &c__107, &c__1, &c__1, & (ls0001_._2) .nst, &c__0, &c__2, &
	    (ls0001_._2) .tn, & (ls0001_._2) .h__, 60L);
L310:

    if ((lsr001_._1) .ngc == 0) {
	goto L315;
    }
    rchek_(&c__3, g, &neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &
	    rwork[(lsr001_._1) .lg0], &rwork[(lsr001_._1) .lg1], &rwork[(lsr001_._1) .lgx], &
	    jroot[1], &irt);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if (irt != 1) {
	goto L315;
    }
    (lsr001_._1) .irfnd = 1;
    *istate = 3;
    *t = (lsr001_._1) .t0;
    goto L425;
L315:

    switch ((int)*itask) {
	case 1:  goto L320;
	case 2:  goto L400;
	case 3:  goto L330;
	case 4:  goto L340;
	case 5:  goto L350;
    }
 

L320:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
 

L330:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) {
	goto L400;
    }
    goto L250;
 

L340:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L345;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
L345:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
    (ls0001_._2) .jstart = -2;
    goto L250;
 

L350:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
 

 
 
 
 
 
 
 
 

L400:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    if (*itask != 4 && *itask != 5) {
	goto L420;
    }
    if (ihit) {
	*t = tcrit;
    }
L420:
    *istate = 2;
L425:
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    rwork[15] = (lsa001_._1) .tsw;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    iwork[19] = (lsa001_._1) .mused;
    iwork[20] = (ls0001_._2) .meth;
    iwork[10] = (lsr001_._1) .nge;
    (lsr001_._1) .tlast = *t;
    return 0;

L430:
    ++ (ls0001_._2) .ntrep;
    if ((ls0001_._2) .ntrep < 5) {
	return 0;
    }
    xerrwv_("lsodar-  repeated calls with istate = 1 and tout = t (=r1)  ", &
	    c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L)
	    ;
    goto L800;
 

 
 
 
 

 
 
 
 

 

L500:
    xerrwv_("lsodar-  at current t (=r1), mxstep (=i1) steps", &c__50, &
	    c__201, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 47L);
    xerrwv_("      taken on this call before reaching tout     ", &c__50, &
	    c__201, &c__1, &c__1, & (ls0001_._2) .mxstep, &c__0, &c__1, &
	    (ls0001_._2) .tn, &c_b61, 50L);
    *istate = -1;
    goto L580;
 

L510:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsodar-  at t (=r1), ewt(i1) has become r2 .le. 0.", &c__50, &
	    c__202, &c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 
	    50L);
    *istate = -6;
    goto L580;
 

L520:
    xerrwv_("lsodar-  at t (=r1), too much accuracy requested ", &c__50, &
	    c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
    xerrwv_("      for precision of machine..  see tolsf (=r2)", &c__50, &
	    c__203, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 
	    49L);
    rwork[14] = tolsf;
    *istate = -2;
    goto L580;
 

L530:
    xerrwv_("lsodar-  at t(=r1) and step size h(=r2), the error", &c__50, &
	    c__204, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      test failed repeatedly or with abs(h) = hmin", &c__50, &
	    c__204, &c__1, &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &
	    (ls0001_._2) .h__, 50L);
    *istate = -4;
    goto L560;
 

L540:
    xerrwv_("lsodar-  at t (=r1) and step size h (=r2), the   ", &c__50, &
	    c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
    xerrwv_("      corrector convergence failed repeatedly    ", &c__50, &
	    c__205, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
    xerrwv_("      or with abs(h) = hmin   ", &c__30, &c__205, &c__1, &c__0, &
	    c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 30L);
    *istate = -5;
    goto L560;
 

L550:
    xerrwv_("lsodar-  at current t(=r1), rwork length too small", &c__50, &
	    c__206, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      to proceed.  the integration was otherwise successful.", &
	    c__60, &c__206, &c__1, &c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &
	    c_b61, 60L);
    *istate = -7;
    goto L580;
 

L555:
    xerrwv_("lsodar-  at current t(=r1), iwork length too small", &c__50, &
	    c__207, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      to proceed.  the integration was otherwise successful.", &
	    c__60, &c__207, &c__1, &c__0, &c__0, &c__0, &c__1, & (ls0001_._2) .tn, &
	    c_b61, 60L);
    *istate = -7;
    goto L580;
 

L560:
    big = 0.;
    imxer = 1;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + 
		(ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (big >= size) {
	    goto L570;
	}
	big = size;
	imxer = i__;
L570:
	;
    }
    iwork[16] = imxer;
 

L580:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    rwork[15] = (lsa001_._1) .tsw;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    iwork[19] = (lsa001_._1) .mused;
    iwork[20] = (ls0001_._2) .meth;
    iwork[10] = (lsr001_._1) .nge;
    (lsr001_._1) .tlast = *t;
    return 0;
 

 
 
 
 
 
 
 

L601:
    xerrwv_("lsodar-  istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, 
	    istate, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L602:
    xerrwv_("lsodar-  itask (=i1) illegal  ", &c__30, &c__2, &c__1, &c__1, 
	    itask, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L603:
    xerrwv_("lsodar-  istate .gt. 1 but lsodar not initialized ", &c__50, &
	    c__3, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L604:
    xerrwv_("lsodar-  neq (=i1) .lt. 1     ", &c__30, &c__4, &c__1, &c__1, &
	    neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L605:
    xerrwv_("lsodar-  istate = 3 and neq increased (i1 to i2)  ", &c__50, &
	    c__5, &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 
	    50L);
    goto L700;
L606:
    xerrwv_("lsodar-  itol (=i1) illegal   ", &c__30, &c__6, &c__1, &c__1, 
	    itol, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L607:
    xerrwv_("lsodar-  iopt (=i1) illegal   ", &c__30, &c__7, &c__1, &c__1, 
	    iopt, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L608:
    xerrwv_("lsodar-  jt (=i1) illegal     ", &c__30, &c__8, &c__1, &c__1, jt,
	     &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L609:
    xerrwv_("lsodar-  ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L610:
    xerrwv_("lsodar-  mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L611:
    xerrwv_("lsodar-  ixpr (=i1) illegal   ", &c__30, &c__11, &c__1, &c__1, &
	    (lsa001_._1) .ixpr, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L612:
    xerrwv_("lsodar-  mxstep (=i1) .lt. 0  ", &c__30, &c__12, &c__1, &c__1, &
	    (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L613:
    xerrwv_("lsodar-  mxhnil (=i1) .lt. 0  ", &c__30, &c__13, &c__1, &c__1, &
	    (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L614:
    xerrwv_("lsodar-  tout (=r1) behind t (=r2)      ", &c__40, &c__14, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    xerrwv_("      integration direction is given by h0 (=r1)  ", &c__50, &
	    c__14, &c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 50L);
    goto L700;
L615:
    xerrwv_("lsodar-  hmax (=r1) .lt. 0.0  ", &c__30, &c__15, &c__1, &c__0, &
	    c__0, &c__0, &c__1, &hmax, &c_b61, 30L);
    goto L700;
L616:
    xerrwv_("lsodar-  hmin (=r1) .lt. 0.0  ", &c__30, &c__16, &c__1, &c__0, &
	    c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L);
    goto L700;
L617:
    xerrwv_("lsodar-  rwork length needed, lenrw (=i1), exceeds lrw (=i2)", &
	    c__60, &c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 
	    60L);
    goto L700;
L618:
    xerrwv_("lsodar-  iwork length needed, leniw (=i1), exceeds liw (=i2)", &
	    c__60, &c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 
	    60L);
    goto L700;
L619:
    xerrwv_("lsodar-  rtol(i1) is r1 .lt. 0.0        ", &c__40, &c__19, &c__1,
	     &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L);
    goto L700;
L620:
    xerrwv_("lsodar-  atol(i1) is r1 .lt. 0.0        ", &c__40, &c__20, &c__1,
	     &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L);
    goto L700;
L621:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsodar-  ewt(i1) is r1 .le. 0.0         ", &c__40, &c__21, &c__1,
	     &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 40L);
    goto L700;
L622:
    xerrwv_("lsodar-  tout (=r1) too close to t(=r2) to start integration", &
	    c__60, &c__22, &c__1, &c__0, &c__0, &c__0, &c__2, tout, t, 60L);
    goto L700;
L623:
    xerrwv_("lsodar-  itask = i1 and tout (=r1) behind tcur - hu (= r2)  ", &
	    c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 60L);
    goto L700;
L624:
    xerrwv_("lsodar-  itask = 4 or 5 and tcrit (=r1) behind tcur (=r2)   ", &
	    c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, &
	    (ls0001_._2) .tn, 60L);
    goto L700;
L625:
    xerrwv_("lsodar-  itask = 4 or 5 and tcrit (=r1) behind tout (=r2)   ", &
	    c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 
	    60L);
    goto L700;
L626:
    xerrwv_("lsodar-  at start of problem, too much accuracy   ", &c__50, &
	    c__26, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      requested for precision of machine..  see tolsf (=r1) ", &
	    c__60, &c__26, &c__1, &c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 
	    60L);
    rwork[14] = tolsf;
    goto L700;
L627:
    xerrwv_("lsodar-  trouble from intdy. itask = i1, tout = r1", &c__50, &
	    c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 50L);
    goto L700;
L628:
    xerrwv_("lsodar-  mxordn (=i1) .lt. 0  ", &c__30, &c__28, &c__1, &c__1, &
	    (lsa001_._1) .mxordn, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L629:
    xerrwv_("lsodar-  mxords (=i1) .lt. 0  ", &c__30, &c__29, &c__1, &c__1, &
	    (lsa001_._1) .mxords, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L630:
    xerrwv_("lsodar-  ng (=i1) .lt. 0      ", &c__30, &c__30, &c__1, &c__1, 
	    ng, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L631:
    xerrwv_("lsodar-  ng changed (from i1 to i2) illegally,    ", &c__50, &
	    c__31, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      i.e. not immediately after a root was found ", &c__50, &
	    c__31, &c__1, &c__2, & (lsr001_._1) .ngc, ng, &c__0, &c_b61, &c_b61, 
	    50L);
    goto L700;
L632:
    xerrwv_("lsodar-  one or more components of g has a root   ", &c__50, &
	    c__32, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("      too near to the initial point     ", &c__40, &c__32, &c__1,
	     &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L);

L700:
    if ((ls0001_._2) .illin == 5) {
	goto L710;
    }
    ++ (ls0001_._2) .illin;
    (lsr001_._1) .tlast = *t;
    *istate = -3;
    return 0;
L710:
    xerrwv_("lsodar-  repeated occurrences of illegal input    ", &c__50, &
	    c__302, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);

L800:
    xerrwv_("lsodar-  run aborted.. apparent infinite loop     ", &c__50, &
	    c__303, &c__2, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    return 0;
 

}  

  int lsode_(f, neq, y, t, tout, itol, rtol, atol, itask, 
	istate, iopt, rwork, lrw, iwork, liw, jac, mf)
  int (*f) ();
integer *neq;
doublereal *y, *t, *tout;
integer *itol;
doublereal *rtol, *atol;
integer *itask, *istate, *iopt;
doublereal *rwork;
integer *lrw, *iwork, *liw;
  int (*jac) ();
integer *mf;
{
     

    static integer mord[2] = { 12,5 };
    static integer mxstp0 = 500;
    static integer mxhnl0 = 10;

     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    static doublereal hmax;
    static logical ihit;
    static doublereal ewti, size;
    static integer i__, iflag;
    static doublereal atoli;
    static integer leniw;
    extern   int prepj_();
    static integer lenwm;
    extern   int stode_();
    static integer imxer;
    static doublereal tcrit;
    static integer lenrw;
    static doublereal h0;
    static integer i1, i2;
    static doublereal rtoli, tdist, tolsf;
    extern doublereal vnorm_();
    static doublereal tnext;
    extern   int ewset_(), intdy_();
    static doublereal w0;
    extern   int solsy_();
    extern doublereal dlamch_();
    static integer ml;
    static doublereal rh;
    static integer mu;
    static doublereal tp;
    static integer lf0;
    extern   int xerrwv_();
    static doublereal big;
    static integer kgo;
    static doublereal ayi, hmx, tol, sum;
     
    --neq;
    --y;
    --rtol;
    --atol;
    --rwork;
    --iwork;
    ierode_ .iero = 0;
    if (*istate < 1 || *istate > 3) {
	goto L601;
    }
    if (*itask < 1 || *itask > 5) {
	goto L602;
    }
    if (*istate == 1) {
	goto L10;
    }
    if ((ls0001_._2) .init == 0) {
	goto L603;
    }
    if (*istate == 2) {
	goto L200;
    }
    goto L20;
L10:
    (ls0001_._2) .init = 0;
    if (*tout == *t) {
	goto L430;
    }
L20:
    (ls0001_._2) .ntrep = 0;
 

 
 
 
 

 
 
 

    if (neq[1] <= 0) {
	goto L604;
    }
    if (*istate == 1) {
	goto L25;
    }
    if (neq[1] > (ls0001_._2) .n) {
	goto L605;
    }
L25:
    (ls0001_._2) .n = neq[1];
    if (*itol < 1 || *itol > 4) {
	goto L606;
    }
    if (*iopt < 0 || *iopt > 1) {
	goto L607;
    }
    (ls0001_._2) .meth = *mf / 10;
    (ls0001_._2) .miter = *mf - (ls0001_._2) .meth * 10;
    if ((ls0001_._2) .meth < 1 || (ls0001_._2) .meth > 2) {
	goto L608;
    }
    if ((ls0001_._2) .miter < 0 || (ls0001_._2) .miter > 5) {
	goto L608;
    }
    if ((ls0001_._2) .miter <= 3) {
	goto L30;
    }
    ml = iwork[1];
    mu = iwork[2];
    if (ml < 0 || ml >= (ls0001_._2) .n) {
	goto L609;
    }
    if (mu < 0 || mu >= (ls0001_._2) .n) {
	goto L610;
    }
L30:
 

    if (*iopt == 1) {
	goto L40;
    }
    (ls0001_._2) .maxord = mord[(ls0001_._2) .meth - 1];
    (ls0001_._2) .mxstep = mxstp0;
    (ls0001_._2) .mxhnil = mxhnl0;
    if (*istate == 1) {
	h0 = 0.;
    }
    (ls0001_._2) .hmxi = 0.;
    (ls0001_._2) .hmin = 0.;
    goto L60;
L40:
    (ls0001_._2) .maxord = iwork[5];
    if ((ls0001_._2) .maxord < 0) {
	goto L611;
    }
    if ((ls0001_._2) .maxord == 0) {
	(ls0001_._2) .maxord = 100;
    }
 
    i__1 = (ls0001_._2) .maxord, i__2 = mord[(ls0001_._2) .meth - 1];
    (ls0001_._2) .maxord = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    (ls0001_._2) .mxstep = iwork[6];
    if ((ls0001_._2) .mxstep < 0) {
	goto L612;
    }
    if ((ls0001_._2) .mxstep == 0) {
	(ls0001_._2) .mxstep = mxstp0;
    }
    (ls0001_._2) .mxhnil = iwork[7];
    if ((ls0001_._2) .mxhnil < 0) {
	goto L613;
    }
    if ((ls0001_._2) .mxhnil == 0) {
	(ls0001_._2) .mxhnil = mxhnl0;
    }
    if (*istate != 1) {
	goto L50;
    }
    h0 = rwork[5];
    if ((*tout - *t) * h0 < 0.) {
	goto L614;
    }
L50:
    hmax = rwork[6];
    if (hmax < 0.) {
	goto L615;
    }
    (ls0001_._2) .hmxi = 0.;
    if (hmax > 0.) {
	(ls0001_._2) .hmxi = 1. / hmax;
    }
    (ls0001_._2) .hmin = rwork[7];
    if ((ls0001_._2) .hmin < 0.) {
	goto L616;
    }
 

 
 
 
 
 

L60:
    (ls0001_._2) .lyh = 21;
    if (*istate == 1) {
	(ls0001_._2) .nyh = (ls0001_._2) .n;
    }
    (ls0001_._2) .lwm = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh;
    if ((ls0001_._2) .miter == 0) {
	lenwm = 0;
    }
    if ((ls0001_._2) .miter == 1 || (ls0001_._2) .miter == 2) {
	lenwm = (ls0001_._2) .n * (ls0001_._2) .n + 2;
    }
    if ((ls0001_._2) .miter == 3) {
	lenwm = (ls0001_._2) .n + 2;
    }
    if ((ls0001_._2) .miter >= 4) {
	lenwm = ((ml << 1) + mu + 1) * (ls0001_._2) .n + 2;
    }
    (ls0001_._2) .lewt = (ls0001_._2) .lwm + lenwm;
    (ls0001_._2) .lsavf = (ls0001_._2) .lewt + (ls0001_._2) .n;
    (ls0001_._2) .lacor = (ls0001_._2) .lsavf + (ls0001_._2) .n;
    lenrw = (ls0001_._2) .lacor + (ls0001_._2) .n - 1;
    iwork[17] = lenrw;
    (ls0001_._2) .liwm = 1;
    leniw = (ls0001_._2) .n + 20;
    if ((ls0001_._2) .miter == 0 || (ls0001_._2) .miter == 3) {
	leniw = 20;
    }
    iwork[18] = leniw;
    if (lenrw > *lrw) {
	goto L617;
    }
    if (leniw > *liw) {
	goto L618;
    }
 

    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol >= 3) {
	    rtoli = rtol[i__];
	}
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	if (rtoli < 0.) {
	    goto L619;
	}
	if (atoli < 0.) {
	    goto L620;
	}
 
    }
    if (*istate == 1) {
	goto L100;
    }
 

    (ls0001_._2) .jstart = -1;
    if ((ls0001_._2) .nq <= (ls0001_._2) .maxord) {
	goto L90;
    }
 

    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + (ls0001_._2) .lsavf - 1] = rwork[i__ + (ls0001_._2) .lwm - 1];
    }
 

L90:
    if ((ls0001_._2) .miter > 0) {
	rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround);
    }
    if ((ls0001_._2) .n == (ls0001_._2) .nyh) {
	goto L200;
    }
 

    i1 = (ls0001_._2) .lyh + (ls0001_._2) .l * (ls0001_._2) .nyh;
    i2 = (ls0001_._2) .lyh + ((ls0001_._2) .maxord + 1) * (ls0001_._2) .nyh - 1;
    if (i1 > i2) {
	goto L200;
    }
    i__1 = i2;
    for (i__ = i1; i__ <= i__1; ++i__) {
 
	rwork[i__] = 0.;
    }
    goto L200;
 

 
 
 
 
 
 

L100:
    (ls0001_._2) .uround = dlamch_("p", 1L);
    (ls0001_._2) .tn = *t;
    if (*itask != 4 && *itask != 5) {
	goto L110;
    }
    tcrit = rwork[1];
    if ((tcrit - *tout) * (*tout - *t) < 0.) {
	goto L625;
    }
    if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) {
	h0 = tcrit - *t;
    }
L110:
    (ls0001_._2) .jstart = 0;
    if ((ls0001_._2) .miter > 0) {
	rwork[(ls0001_._2) .lwm] = sqrt((ls0001_._2) .uround);
    }
    (ls0001_._2) .nhnil = 0;
    (ls0001_._2) .nst = 0;
    (ls0001_._2) .nje = 0;
    (ls0001_._2) .nslast = 0;
    (ls0001_._2) .hu = 0.;
    (ls0001_._2) .nqu = 0;
    (ls0001_._2) .ccmax = .3;
    (ls0001_._2) .maxcor = 3;
    (ls0001_._2) .msbp = 20;
    (ls0001_._2) .mxncf = 10;
 

    lf0 = (ls0001_._2) .lyh + (ls0001_._2) .nyh;
    (*f)(&neq[1], t, &y[1], &rwork[lf0]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    (ls0001_._2) .nfe = 1;
 

    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + (ls0001_._2) .lyh - 1] = y[i__];
    }
 

    (ls0001_._2) .nq = 1;
    (ls0001_._2) .h__ = 1.;
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L621;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

    if (h0 != 0.) {
	goto L180;
    }
    tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
    d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if (tdist < (ls0001_._2) .uround * 2. * w0) {
	goto L622;
    }
    tol = rtol[1];
    if (*itol <= 2) {
	goto L140;
    }
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = tol, d__2 = rtol[i__];
	tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
L140:
    if (tol > 0.) {
	goto L160;
    }
    atoli = atol[1];
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (ayi != 0.) {
 
	    d__1 = tol, d__2 = atoli / ayi;
	    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	}
 
    }
L160:
 
    d__1 = tol, d__2 = (ls0001_._2) .uround * 100.;
    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ;
    sum = vnorm_(& (ls0001_._2) .n, &rwork[lf0], &rwork[(ls0001_._2) .lewt]);
 
    d__1 = sum;
    sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1);
    h0 = 1. / sqrt(sum);
    h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ;
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);
 

L180:
    rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 ))  * (ls0001_._2) .hmxi;
    if (rh > 1.) {
	h0 /= rh;
    }
 

    (ls0001_._2) .h__ = h0;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + lf0 - 1] = h0 * rwork[i__ + lf0 - 1];
    }
    goto L270;
 

 
 
 
 

L200:
    (ls0001_._2) .nslast = (ls0001_._2) .nst;
    switch ((int)*itask) {
	case 1:  goto L210;
	case 2:  goto L250;
	case 3:  goto L220;
	case 4:  goto L230;
	case 5:  goto L240;
    }
L210:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L220:
    tp = (ls0001_._2) .tn - (ls0001_._2) .hu * ((ls0001_._2) .uround * 100. + 1.);
    if ((tp - *tout) * (ls0001_._2) .h__ > 0.) {
	goto L623;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    goto L400;
L230:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
    if ((tcrit - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L625;
    }
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L245;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L240:
    tcrit = rwork[1];
    if (((ls0001_._2) .tn - tcrit) * (ls0001_._2) .h__ > 0.) {
	goto L624;
    }
L245:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
    if (*istate == 2) {
	(ls0001_._2) .jstart = -2;
    }
 

 
 
 

 

 
 
 
 

L250:
    if ((ls0001_._2) .nst - (ls0001_._2) .nslast >= (ls0001_._2) .mxstep) {
	goto L500;
    }
    ewset_(& (ls0001_._2) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._2) .lewt - 1] <= 0.) {
	    goto L510;
	}
 
	rwork[i__ + (ls0001_._2) .lewt - 1] = 1. / rwork[i__ + (ls0001_._2) .lewt - 1];
    }
L270:
    tolsf = (ls0001_._2) .uround * vnorm_(& (ls0001_._2) .n, &rwork[(ls0001_._2) .lyh], &
	    rwork[(ls0001_._2) .lewt]);
    if (tolsf <= 1.) {
	goto L280;
    }
    tolsf *= 2.;
    if ((ls0001_._2) .nst == 0) {
	goto L626;
    }
    goto L520;
L280:
    if ((ls0001_._2) .tn + (ls0001_._2) .h__ != (ls0001_._2) .tn) {
	goto L290;
    }
    ++ (ls0001_._2) .nhnil;
    if ((ls0001_._2) .nhnil > (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsode--  caution... t (=r1) and h (=r2) are", &c__50, &c__101, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 43L);
    xerrwv_("     such that t + h = t at next step", &c__60, &c__101, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L);
    xerrwv_("      (h = pas).  integration continues", &c__50, &c__101, &c__1,
	     &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 39L);
    if ((ls0001_._2) .nhnil < (ls0001_._2) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsode--  preceding message given i1 times", &c__50, &c__102, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 41L);
    xerrwv_("     wiil not be repeated", &c__50, &c__102, &c__1, &c__1, &
	    (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 25L);
L290:
 

 

 

    stode_(&neq[1], &y[1], &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &rwork[
	    (ls0001_._2) .lyh], &rwork[(ls0001_._2) .lewt], &rwork[(ls0001_._2) .lsavf], &
	    rwork[(ls0001_._2) .lacor], &rwork[(ls0001_._2) .lwm], &iwork[(ls0001_._2) .liwm]
	    , f, jac, prepj_, solsy_);
    if (ierode_ .iero > 0) {
	return 0;
    }
    kgo = 1 - (ls0001_._2) .kflag;
    switch ((int)kgo) {
	case 1:  goto L300;
	case 2:  goto L530;
	case 3:  goto L540;
    }
 

 
 
 
 

L300:
    (ls0001_._2) .init = 1;
    switch ((int)*itask) {
	case 1:  goto L310;
	case 2:  goto L400;
	case 3:  goto L330;
	case 4:  goto L340;
	case 5:  goto L350;
    }
 

L310:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
 

L330:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ >= 0.) {
	goto L400;
    }
    goto L250;
 

L340:
    if (((ls0001_._2) .tn - *tout) * (ls0001_._2) .h__ < 0.) {
	goto L345;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._2) .lyh], & (ls0001_._2) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
L345:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._2) .tn + (ls0001_._2) .h__ * ((ls0001_._2) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._2) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._2) .h__ = (tcrit - (ls0001_._2) .tn) * (1. - (ls0001_._2) .uround * 4.);
    (ls0001_._2) .jstart = -2;
    goto L250;
 

L350:
    hmx = (( (ls0001_._2) .tn ) >= 0 ? ( (ls0001_._2) .tn ) : -( (ls0001_._2) .tn ))  + (( (ls0001_._2) .h__ ) >= 0 ? ( (ls0001_._2) .h__ ) : -( (ls0001_._2) .h__ )) ;
    ihit = (d__1 = (ls0001_._2) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._2) .uround * 100. *
	     hmx;
 

 
 
 
 
 
 
 
 

L400:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    if (*itask != 4 && *itask != 5) {
	goto L420;
    }
    if (ihit) {
	*t = tcrit;
    }
L420:
    *istate = 2;
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    return 0;

L430:
    ++ (ls0001_._2) .ntrep;
    if ((ls0001_._2) .ntrep < 5) {
	return 0;
    }
    xerrwv_("lsode--  calls with istate = 1 and tout = t (=r1)  ", &c__60, &
	    c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 51L);
    goto L800;
 

 
 
 
 

 
 
 
 

 

L500:
    xerrwv_("lsode--  at t (=r1), mxstep (=i1) steps   ", &c__50, &c__201, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L);
    xerrwv_("necessary before reaching tout", &c__50, &c__201, &c__1, &c__1, &
	    (ls0001_._2) .mxstep, &c__0, &c__1, & (ls0001_._2) .tn, &c_b61, 30L);
    *istate = -1;
    goto L580;
 

L510:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsode--  at t (=r1),ewt(i1) (=r2) is .le.0", &c__50, &c__202, &
	    c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._2) .tn, &ewti, 42L);
    *istate = -6;
    goto L580;
 

L520:
    xerrwv_("lsode--  a t (=r1),  too much precision required", &c__50, &
	    c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 48L);
    xerrwv_(" w.r.t. machine precision tolsf (=r2) ", &c__50, &c__203, &c__1, 
	    &c__0, &c__0, &c__0, &c__2, & (ls0001_._2) .tn, &tolsf, 38L);
    rwork[14] = tolsf;
    *istate = -2;
    goto L580;
 

L530:
    xerrwv_("lsode--  at t(=r1) for step h(=r2), error test", &c__50, &c__204,
	     &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L);
    xerrwv_("    failed with abs(h) = hmin", &c__50, &c__204, &c__1, &c__0, &
	    c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 29L);
    *istate = -4;
    goto L560;
 

L540:
    xerrwv_("lsode--  at t (=r1) with step h (=r2), ", &c__50, &c__205, &c__1,
	     &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 39L);
    xerrwv_("     corrector does not converge ", &c__50, &c__205, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 33L);
    xerrwv_("      with abs(h) = hmin   ", &c__30, &c__205, &c__1, &c__0, &
	    c__0, &c__0, &c__2, & (ls0001_._2) .tn, & (ls0001_._2) .h__, 27L);
    *istate = -5;
 

L560:
    big = 0.;
    imxer = 1;
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	size = (d__1 = rwork[i__ + (ls0001_._2) .lacor - 1] * rwork[i__ + 
		(ls0001_._2) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (big >= size) {
	    goto L570;
	}
	big = size;
	imxer = i__;
L570:
	;
    }
    iwork[16] = imxer;
 

L580:
    i__1 = (ls0001_._2) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._2) .lyh - 1];
    }
    *t = (ls0001_._2) .tn;
    (ls0001_._2) .illin = 0;
    rwork[11] = (ls0001_._2) .hu;
    rwork[12] = (ls0001_._2) .h__;
    rwork[13] = (ls0001_._2) .tn;
    iwork[11] = (ls0001_._2) .nst;
    iwork[12] = (ls0001_._2) .nfe;
    iwork[13] = (ls0001_._2) .nje;
    iwork[14] = (ls0001_._2) .nqu;
    iwork[15] = (ls0001_._2) .nq;
    return 0;
 

 
 
 
 
 
 
 

L601:
    xerrwv_("lsode--  istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, 
	    istate, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L602:
    xerrwv_("lsode--  itask (=i1) illegal  ", &c__30, &c__2, &c__1, &c__1, 
	    itask, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L603:
    xerrwv_("lsode--  istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 23L);
    goto L700;
L604:
    xerrwv_("lsode--  neq (=i1) .lt. 1     ", &c__30, &c__4, &c__1, &c__1, &
	    neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L605:
    xerrwv_("lsode--  istate and neq  increased from i1 to i2", &c__50, &c__5,
	     &c__1, &c__2, & (ls0001_._2) .n, &neq[1], &c__0, &c_b61, &c_b61, 48L);
    goto L700;
L606:
    xerrwv_("lsode--  itol (=i1) illegal   ", &c__30, &c__6, &c__1, &c__1, 
	    itol, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L607:
    xerrwv_("lsode--  iopt (=i1) illegal   ", &c__30, &c__7, &c__1, &c__1, 
	    iopt, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L608:
    xerrwv_("lsode--  mf (=i1) illegal     ", &c__30, &c__8, &c__1, &c__1, mf,
	     &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L609:
    xerrwv_("lsode--  ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L610:
    xerrwv_("lsode--  mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L611:
    xerrwv_("lsode--  maxord (=i1) .lt. 0  ", &c__30, &c__11, &c__1, &c__1, &
	    (ls0001_._2) .maxord, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L612:
    xerrwv_("lsode--  mxstep (=i1) .lt. 0  ", &c__30, &c__12, &c__1, &c__1, &
	    (ls0001_._2) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L613:
    xerrwv_("lsode--  mxhnil (=i1) .lt. 0  ", &c__30, &c__13, &c__1, &c__1, &
	    (ls0001_._2) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L614:
    xerrwv_("lsode--  tout (=r1)  .gt.  t (=r2)      ", &c__40, &c__14, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    xerrwv_("      h0 (=r1) gives integration direction", &c__50, &c__14, &
	    c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 42L);
    goto L700;
L615:
    xerrwv_("lsode--  hmax (=r1) .lt. 0.0  ", &c__30, &c__15, &c__1, &c__0, &
	    c__0, &c__0, &c__1, &hmax, &c_b61, 30L);
    goto L700;
L616:
    xerrwv_("lsode--  hmin (=r1) .lt. 0.0  ", &c__30, &c__16, &c__1, &c__0, &
	    c__0, &c__0, &c__1, & (ls0001_._2) .hmin, &c_b61, 30L);
    goto L700;
L617:
    xerrwv_("lsode-- necessary size for rwork (i1) larger than i2", &c__60, &
	    c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 52L);
    goto L700;
L618:
    xerrwv_("lsode-- necessary size for iwork (i1) larger than liw (i2)", &
	    c__60, &c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 
	    58L);
    goto L700;
L619:
    xerrwv_("lsode--  rtol(i1) est r1 .lt. 0.0        ", &c__40, &c__19, &
	    c__1, &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 41L);
    goto L700;
L620:
    xerrwv_("lsode--  atol(i1) est r1 .lt. 0.0        ", &c__40, &c__20, &
	    c__1, &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 41L);
    goto L700;
L621:
    ewti = rwork[(ls0001_._2) .lewt + i__ - 1];
    xerrwv_("lsode--  ewt(i1) (=r1) est .le. 0.0         ", &c__40, &c__21, &
	    c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 44L);
    goto L700;
L622:
    xerrwv_("lsode--  tout (=r1) too close to t(=r2) ", &c__60, &c__22, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    goto L700;
L623:
    xerrwv_("lsode--  itask (=i1) and tout (=r1) .gt. tcur - hu (= r2)  ", &
	    c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 59L);
    goto L700;
L624:
    xerrwv_("lsode--  itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2)   ", &
	    c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, &
	    (ls0001_._2) .tn, 58L);
    goto L700;
L625:
    xerrwv_("lsode--  itask = 4 or 5 and tcrit (=r1)  .gt.  tout (=r2)", &
	    c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 
	    57L);
    goto L700;
L626:
    xerrwv_("lsode-- initial precision required", &c__50, &c__26, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L);
    xerrwv_("too high wrt machine precision tolsf (=r1)", &c__60, &c__26, &
	    c__1, &c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 42L);
    rwork[14] = tolsf;
    goto L700;
L627:
    xerrwv_("lsode--  problems in intdy. itask=i1,tout=r1", &c__50, &c__27, &
	    c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 44L);

L700:
    if ((ls0001_._2) .illin == 5) {
	goto L710;
    }
    ++ (ls0001_._2) .illin;
    *istate = -3;
    return 0;
L710:
    xerrwv_("lsode-- incorrect inputs", &c__50, &c__302, &c__1, &c__0, &c__0, 
	    &c__0, &c__0, &c_b61, &c_b61, 24L);

L800:
    xerrwv_("lsode-- infinite loop ", &c__50, &c__303, &c__2, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 22L);
    return 0;
 

}  

 
  int lsodi_(res, adda, jac, neq, y, ydoti, t, tout, itol, 
	rtol, atol, itask, istate, iopt, rwork, lrw, iwork, liw, mf)
  int (*res) (), (*adda) (), (*jac) ();
integer *neq;
doublereal *y, *ydoti, *t, *tout;
integer *itol;
doublereal *rtol, *atol;
integer *itask, *istate, *iopt;
doublereal *rwork;
integer *lrw, *iwork, *liw, *mf;
{
     

    static integer mord[2] = { 12,5 };
    static integer mxstp0 = 500;
    static integer mxhnl0 = 10;

     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt(), d_sign();

     
    static doublereal hmax;
    static logical ihit;
    static integer ires;
    static doublereal ewti, size;
    static integer i__, iflag;
    extern   int ainvg_();
    static doublereal atoli;
    static integer leniw, lenwm;
    extern   int stodi_();
    static integer imxer;
    static doublereal tcrit;
    static integer i1, i2, lenrw;
    static doublereal h0, rtoli, tdist, tnext, tolsf;
    extern doublereal vnorm_();
    extern   int ewset_();
    static doublereal w0;
    extern   int solsy_();
    extern   int intdy_();
    extern doublereal dlamch_();
    static integer ml;
    static doublereal rh;
    static integer lp, mu;
    static doublereal tp;
    extern   int prepji_();
    extern   int xerrwv_();
    static doublereal big;
    static integer ier, kgo;
    static doublereal ayi, hmx, tol, sum;
    static integer lyd0;
     
    --neq;
    --y;
    --ydoti;
    --rtol;
    --atol;
    --rwork;
    --iwork;

    ierode_ .iero = 0;
    if (*istate < 0 || *istate > 3) {
	goto L601;
    }
    if (*itask < 1 || *itask > 5) {
	goto L602;
    }
    if (*istate <= 1) {
	goto L10;
    }
    if ((ls0001_._3) .init == 0) {
	goto L603;
    }
    if (*istate == 2) {
	goto L200;
    }
    goto L20;
L10:
    (ls0001_._3) .init = 0;
    if (*tout == *t) {
	goto L430;
    }
L20:
    (ls0001_._3) .ntrep = 0;
 

 
 

 
 

 
 
 

    if (neq[1] <= 0) {
	goto L604;
    }
    if (*istate <= 1) {
	goto L25;
    }
    if (neq[1] > (ls0001_._3) .n) {
	goto L605;
    }
L25:
    (ls0001_._3) .n = neq[1];
    if (*itol < 1 || *itol > 4) {
	goto L606;
    }
    if (*iopt < 0 || *iopt > 1) {
	goto L607;
    }
    (ls0001_._3) .meth = *mf / 10;
    (ls0001_._3) .miter = *mf - (ls0001_._3) .meth * 10;
    if ((ls0001_._3) .meth < 1 || (ls0001_._3) .meth > 2) {
	goto L608;
    }
    if ((ls0001_._3) .miter <= 0 || (ls0001_._3) .miter > 5) {
	goto L608;
    }
    if ((ls0001_._3) .miter == 3) {
	goto L608;
    }
    if ((ls0001_._3) .miter < 3) {
	goto L30;
    }
    ml = iwork[1];
    mu = iwork[2];
    if (ml < 0 || ml >= (ls0001_._3) .n) {
	goto L609;
    }
    if (mu < 0 || mu >= (ls0001_._3) .n) {
	goto L610;
    }
L30:
 

    if (*iopt == 1) {
	goto L40;
    }
    (ls0001_._3) .maxord = mord[(ls0001_._3) .meth - 1];
    (ls0001_._3) .mxstep = mxstp0;
    (ls0001_._3) .mxhnil = mxhnl0;
    if (*istate <= 1) {
	h0 = 0.;
    }
    (ls0001_._3) .hmxi = 0.;
    (ls0001_._3) .hmin = 0.;
    goto L60;
L40:
    (ls0001_._3) .maxord = iwork[5];
    if ((ls0001_._3) .maxord < 0) {
	goto L611;
    }
    if ((ls0001_._3) .maxord == 0) {
	(ls0001_._3) .maxord = 100;
    }
 
    i__1 = (ls0001_._3) .maxord, i__2 = mord[(ls0001_._3) .meth - 1];
    (ls0001_._3) .maxord = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    (ls0001_._3) .mxstep = iwork[6];
    if ((ls0001_._3) .mxstep < 0) {
	goto L612;
    }
    if ((ls0001_._3) .mxstep == 0) {
	(ls0001_._3) .mxstep = mxstp0;
    }
    (ls0001_._3) .mxhnil = iwork[7];
    if ((ls0001_._3) .mxhnil < 0) {
	goto L613;
    }
    if ((ls0001_._3) .mxhnil == 0) {
	(ls0001_._3) .mxhnil = mxhnl0;
    }
    if (*istate > 1) {
	goto L50;
    }
    h0 = rwork[5];
    if ((*tout - *t) * h0 < 0.) {
	goto L614;
    }
L50:
    hmax = rwork[6];
    if (hmax < 0.) {
	goto L615;
    }
    (ls0001_._3) .hmxi = 0.;
    if (hmax > 0.) {
	(ls0001_._3) .hmxi = 1. / hmax;
    }
    (ls0001_._3) .hmin = rwork[7];
    if ((ls0001_._3) .hmin < 0.) {
	goto L616;
    }
 

 
 
 
 
 

L60:
    (ls0001_._3) .lyh = 21;
    if (*istate <= 1) {
	(ls0001_._3) .nyh = (ls0001_._3) .n;
    }
    (ls0001_._3) .lwm = (ls0001_._3) .lyh + ((ls0001_._3) .maxord + 1) * (ls0001_._3) .nyh;
    if ((ls0001_._3) .miter <= 2) {
	lenwm = (ls0001_._3) .n * (ls0001_._3) .n + 2;
    }
    if ((ls0001_._3) .miter >= 4) {
	lenwm = ((ml << 1) + mu + 1) * (ls0001_._3) .n + 2;
    }
    (ls0001_._3) .lewt = (ls0001_._3) .lwm + lenwm;
    (ls0001_._3) .lsavr = (ls0001_._3) .lewt + (ls0001_._3) .n;
    (ls0001_._3) .lacor = (ls0001_._3) .lsavr + (ls0001_._3) .n;
    lenrw = (ls0001_._3) .lacor + (ls0001_._3) .n - 1;
    iwork[17] = lenrw;
    (ls0001_._3) .liwm = 1;
    leniw = (ls0001_._3) .n + 20;
    iwork[18] = leniw;
    if (lenrw > *lrw) {
	goto L617;
    }
    if (leniw > *liw) {
	goto L618;
    }
 

    rtoli = rtol[1];
    atoli = atol[1];
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol >= 3) {
	    rtoli = rtol[i__];
	}
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	if (rtoli < 0.) {
	    goto L619;
	}
	if (atoli < 0.) {
	    goto L620;
	}
 
    }
    if (*istate <= 1) {
	goto L100;
    }
 

    (ls0001_._3) .jstart = -1;
    if ((ls0001_._3) .nq <= (ls0001_._3) .maxord) {
	goto L90;
    }
 

    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	ydoti[i__] = rwork[i__ + (ls0001_._3) .lwm - 1];
    }
 

L90:
    rwork[(ls0001_._3) .lwm] = sqrt((ls0001_._3) .uround);
    if ((ls0001_._3) .n == (ls0001_._3) .nyh) {
	goto L200;
    }
 

    i1 = (ls0001_._3) .lyh + (ls0001_._3) .l * (ls0001_._3) .nyh;
    i2 = (ls0001_._3) .lyh + ((ls0001_._3) .maxord + 1) * (ls0001_._3) .nyh - 1;
    if (i1 > i2) {
	goto L200;
    }
    i__1 = i2;
    for (i__ = i1; i__ <= i__1; ++i__) {
 
	rwork[i__] = 0.;
    }
    goto L200;
 

 
 
 
 
 
 

L100:
    (ls0001_._3) .uround = dlamch_("p", 1L);
    (ls0001_._3) .tn = *t;
    if (*itask != 4 && *itask != 5) {
	goto L105;
    }
    tcrit = rwork[1];
    if ((tcrit - *tout) * (*tout - *t) < 0.) {
	goto L625;
    }
    if (h0 != 0. && (*t + h0 - tcrit) * h0 > 0.) {
	h0 = tcrit - *t;
    }
L105:
    (ls0001_._3) .jstart = 0;
    rwork[(ls0001_._3) .lwm] = sqrt((ls0001_._3) .uround);
    (ls0001_._3) .nhnil = 0;
    (ls0001_._3) .nst = 0;
    (ls0001_._3) .nre = 0;
    (ls0001_._3) .nje = 0;
    (ls0001_._3) .nslast = 0;
    (ls0001_._3) .hu = 0.;
    (ls0001_._3) .nqu = 0;
    (ls0001_._3) .ccmax = .3;
    (ls0001_._3) .maxcor = 3;
    (ls0001_._3) .msbp = 20;
    (ls0001_._3) .mxncf = 10;
 

    lyd0 = (ls0001_._3) .lyh + (ls0001_._3) .nyh;
    lp = (ls0001_._3) .lwm + 1;
    if (*istate == 1) {
	goto L120;
    }
 

    ainvg_(res, adda, &neq[1], t, &y[1], &rwork[lyd0], & (ls0001_._3) .miter, &ml, &
	    mu, &rwork[lp], &iwork[21], &ier);
    ++ (ls0001_._3) .nre;
    if (ier < 0) {
	goto L560;
    } else if (ier == 0) {
	goto L110;
    } else {
	goto L565;
    }
L110:
    if (ierode_ .iero > 0) {
	return 0;
    }
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + (ls0001_._3) .lyh - 1] = y[i__];
    }
    goto L130;
 

L120:
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	rwork[i__ + (ls0001_._3) .lyh - 1] = y[i__];
 
	rwork[i__ + lyd0 - 1] = ydoti[i__];
    }
 

L130:
    (ls0001_._3) .nq = 1;
    (ls0001_._3) .h__ = 1.;
    ewset_(& (ls0001_._3) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._3) .lyh], &
	    rwork[(ls0001_._3) .lewt]);
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._3) .lewt - 1] <= 0.) {
	    goto L621;
	}
 
	rwork[i__ + (ls0001_._3) .lewt - 1] = 1. / rwork[i__ + (ls0001_._3) .lewt - 1];
    }
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

    if (h0 != 0.) {
	goto L180;
    }
    tdist = (d__1 = *tout - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
    d__1 = (( *t ) >= 0 ? ( *t ) : -( *t )) , d__2 = (( *tout ) >= 0 ? ( *tout ) : -( *tout )) ;
    w0 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if (tdist < (ls0001_._3) .uround * 2. * w0) {
	goto L622;
    }
    tol = rtol[1];
    if (*itol <= 2) {
	goto L145;
    }
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = tol, d__2 = rtol[i__];
	tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
L145:
    if (tol > 0.) {
	goto L160;
    }
    atoli = atol[1];
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*itol == 2 || *itol == 4) {
	    atoli = atol[i__];
	}
	ayi = (d__1 = y[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (ayi != 0.) {
 
	    d__1 = tol, d__2 = atoli / ayi;
	    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	}
 
    }
L160:
 
    d__1 = tol, d__2 = (ls0001_._3) .uround * 100.;
    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    tol = (( tol ) <= ( .001 ) ? ( tol ) : ( .001 )) ;
    sum = vnorm_(& (ls0001_._3) .n, &rwork[lyd0], &rwork[(ls0001_._3) .lewt]);
 
    d__1 = sum;
    sum = 1. / (tol * w0 * w0) + tol * (d__1 * d__1);
    h0 = 1. / sqrt(sum);
    h0 = (( h0 ) <= ( tdist ) ? ( h0 ) : ( tdist )) ;
    d__1 = *tout - *t;
    h0 = d_sign(&h0, &d__1);
 

L180:
    rh = (( h0 ) >= 0 ? ( h0 ) : -( h0 ))  * (ls0001_._3) .hmxi;
    if (rh > 1.) {
	h0 /= rh;
    }
 

    (ls0001_._3) .h__ = h0;
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rwork[i__ + lyd0 - 1] = h0 * rwork[i__ + lyd0 - 1];
    }
    goto L270;
 

 
 
 
 

L200:
    (ls0001_._3) .nslast = (ls0001_._3) .nst;
    switch ((int)*itask) {
	case 1:  goto L210;
	case 2:  goto L250;
	case 3:  goto L220;
	case 4:  goto L230;
	case 5:  goto L240;
    }
L210:
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L220:
    tp = (ls0001_._3) .tn - (ls0001_._3) .hu * ((ls0001_._3) .uround * 100. + 1.);
    if ((tp - *tout) * (ls0001_._3) .h__ > 0.) {
	goto L623;
    }
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L250;
    }
    goto L400;
L230:
    tcrit = rwork[1];
    if (((ls0001_._3) .tn - tcrit) * (ls0001_._3) .h__ > 0.) {
	goto L624;
    }
    if ((tcrit - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L625;
    }
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L245;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag);
    if (iflag != 0) {
	goto L627;
    }
    *t = *tout;
    goto L420;
L240:
    tcrit = rwork[1];
    if (((ls0001_._3) .tn - tcrit) * (ls0001_._3) .h__ > 0.) {
	goto L624;
    }
L245:
    hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn ))  + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ;
    ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._3) .tn + (ls0001_._3) .h__ * ((ls0001_._3) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._3) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._3) .h__ = (tcrit - (ls0001_._3) .tn) * (1. - (ls0001_._3) .uround * 4.);
    if (*istate == 2) {
	(ls0001_._3) .jstart = -2;
    }
 

 
 
 

 

 
 
 
 

L250:
    if ((ls0001_._3) .nst - (ls0001_._3) .nslast >= (ls0001_._3) .mxstep) {
	goto L500;
    }
    ewset_(& (ls0001_._3) .n, itol, &rtol[1], &atol[1], &rwork[(ls0001_._3) .lyh], &
	    rwork[(ls0001_._3) .lewt]);
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (rwork[i__ + (ls0001_._3) .lewt - 1] <= 0.) {
	    goto L510;
	}
 
	rwork[i__ + (ls0001_._3) .lewt - 1] = 1. / rwork[i__ + (ls0001_._3) .lewt - 1];
    }
L270:
    tolsf = (ls0001_._3) .uround * vnorm_(& (ls0001_._3) .n, &rwork[(ls0001_._3) .lyh], &
	    rwork[(ls0001_._3) .lewt]);
    if (tolsf <= 1.) {
	goto L280;
    }
    tolsf *= 2.;
    if ((ls0001_._3) .nst == 0) {
	goto L626;
    }
    goto L520;
L280:
    if ((ls0001_._3) .tn + (ls0001_._3) .h__ != (ls0001_._3) .tn) {
	goto L290;
    }
    ++ (ls0001_._3) .nhnil;
    if ((ls0001_._3) .nhnil > (ls0001_._3) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsodi--  attention.. t (=r1) and h (=r2) are", &c__50, &c__101, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 44L);
    xerrwv_("    such that  t + h = t at next step", &c__60, &c__101, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 37L);
    xerrwv_("      (h = pas). integration continues", &c__50, &c__101, &c__1, 
	    &c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 38L);
    if ((ls0001_._3) .nhnil < (ls0001_._3) .mxhnil) {
	goto L290;
    }
    xerrwv_("lsodi--  previous message has been given i1 times", &c__50, &
	    c__102, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
    xerrwv_("     it will not be repeated", &c__50, &c__102, &c__1, &c__1, &
	    (ls0001_._3) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 28L);
L290:
 

 
 
 
 

    stodi_(&neq[1], &y[1], &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &rwork[
	    (ls0001_._3) .lyh], &rwork[(ls0001_._3) .lewt], &ydoti[1], &rwork[
	    (ls0001_._3) .lsavr], &rwork[(ls0001_._3) .lacor], &rwork[(ls0001_._3) .lwm], &
	    iwork[(ls0001_._3) .liwm], res, adda, jac, prepji_, solsy_);
    if (ierode_ .iero > 0) {
	return 0;
    }
    kgo = 1 - (ls0001_._3) .kflag;
    switch ((int)kgo) {
	case 1:  goto L300;
	case 2:  goto L530;
	case 3:  goto L540;
	case 4:  goto L400;
	case 5:  goto L550;
    }

 
 
 

 
 
 
 

L300:
    (ls0001_._3) .init = 1;
    switch ((int)*itask) {
	case 1:  goto L310;
	case 2:  goto L400;
	case 3:  goto L330;
	case 4:  goto L340;
	case 5:  goto L350;
    }
 

L310:
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L250;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
 

L330:
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ >= 0.) {
	goto L400;
    }
    goto L250;
 

L340:
    if (((ls0001_._3) .tn - *tout) * (ls0001_._3) .h__ < 0.) {
	goto L345;
    }
    intdy_(tout, &c__0, &rwork[(ls0001_._3) .lyh], & (ls0001_._3) .nyh, &y[1], &iflag);
    *t = *tout;
    goto L420;
L345:
    hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn ))  + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ;
    ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. *
	     hmx;
    if (ihit) {
	goto L400;
    }
    tnext = (ls0001_._3) .tn + (ls0001_._3) .h__ * ((ls0001_._3) .uround * 4. + 1.);
    if ((tnext - tcrit) * (ls0001_._3) .h__ <= 0.) {
	goto L250;
    }
    (ls0001_._3) .h__ = (tcrit - (ls0001_._3) .tn) * (1. - (ls0001_._3) .uround * 4.);
    (ls0001_._3) .jstart = -2;
    goto L250;
 

L350:
    hmx = (( (ls0001_._3) .tn ) >= 0 ? ( (ls0001_._3) .tn ) : -( (ls0001_._3) .tn ))  + (( (ls0001_._3) .h__ ) >= 0 ? ( (ls0001_._3) .h__ ) : -( (ls0001_._3) .h__ )) ;
    ihit = (d__1 = (ls0001_._3) .tn - tcrit, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= (ls0001_._3) .uround * 100. *
	     hmx;
 

 
 
 
 
 

 

 
 

L400:
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1];
    }
    *t = (ls0001_._3) .tn;
    if (*itask != 4 && *itask != 5) {
	goto L420;
    }
    if (ihit) {
	*t = tcrit;
    }
L420:
    *istate = 2;
    if ((ls0001_._3) .kflag == -3) {
	*istate = 3;
    }
    (ls0001_._3) .illin = 0;
    rwork[11] = (ls0001_._3) .hu;
    rwork[12] = (ls0001_._3) .h__;
    rwork[13] = (ls0001_._3) .tn;
    iwork[11] = (ls0001_._3) .nst;
    iwork[12] = (ls0001_._3) .nre;
    iwork[13] = (ls0001_._3) .nje;
    iwork[14] = (ls0001_._3) .nqu;
    iwork[15] = (ls0001_._3) .nq;
    return 0;

L430:
    ++ (ls0001_._3) .ntrep;
    if ((ls0001_._3) .ntrep < 5) {
	return 0;
    }
    xerrwv_("lsodi--  repeated calls with istate=0 or 1 and tout=t (r1)  ", &
	    c__60, &c__301, &c__1, &c__0, &c__0, &c__0, &c__1, t, &c_b61, 60L)
	    ;
    goto L800;
 

 
 
 
 

 
 
 
 

 

L500:
    xerrwv_("lsodi--  at t (=r1), mxstep (=i1) steps   ", &c__50, &c__201, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 42L);
    xerrwv_("necessary before reaching tout", &c__50, &c__201, &c__1, &c__1, &
	    (ls0001_._3) .mxstep, &c__0, &c__1, & (ls0001_._3) .tn, &c_b61, 30L);
    *istate = -1;
    goto L580;
 

L510:
    ewti = rwork[(ls0001_._3) .lewt + i__ - 1];
    xerrwv_("lsodi--  at t (=r1), ewt(i1) (r2) is .le. 0", &c__50, &c__202, &
	    c__1, &c__1, &i__, &c__0, &c__2, & (ls0001_._3) .tn, &ewti, 43L);
    *istate = -6;
    goto L590;
L520:
    xerrwv_("lsodi--  at t (=r1),  too much precision required", &c__50, &
	    c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 49L);
 

    xerrwv_(" w.r.t. machine precision  tolsf (=r2) ", &c__50, &c__203, &c__1,
	     &c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, &tolsf, 39L);
    rwork[14] = tolsf;
    *istate = -2;
    goto L590;
 

L530:
    xerrwv_("lsodi--  at t(=r1) anf for h(=r2), error", &c__50, &c__204, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L);
    xerrwv_("      test failed with abs(h) = hmin", &c__50, &c__204, &c__1, &
	    c__0, &c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 36L);
    *istate = -4;
    goto L570;
 

L540:
    xerrwv_("lsodi--  at t (=r1) for step h (=r2), le", &c__50, &c__205, &
	    c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 40L);
    xerrwv_("    corrector does not converge ", &c__50, &c__205, &c__1, &c__0,
	     &c__0, &c__0, &c__0, &c_b61, &c_b61, 32L);
    xerrwv_("      with abs(h) = hmin   ", &c__30, &c__205, &c__1, &c__0, &
	    c__0, &c__0, &c__2, & (ls0001_._3) .tn, & (ls0001_._3) .h__, 27L);
    *istate = -5;
    goto L570;
 

L550:
    xerrwv_("lsodi--  at t (=r1) repeated error (ires=3) due to ", &c__50, &
	    c__206, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 51L);
    xerrwv_("routine which evaluates the residue", &c__30, &c__206, &c__1, &
	    c__0, &c__0, &c__0, &c__1, & (ls0001_._3) .tn, &c_b61, 35L);
    *istate = -7;
    goto L590;
 

L560:
    ier = -ier;
    xerrwv_("lsodi-- initialization failed dy/dt: singular matrix", &c__60, &
	    c__207, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 52L);
    xerrwv_("dgefa or dgbfa return info=(i1)", &c__50, &c__207, &c__1, &c__1, 
	    &ier, &c__0, &c__0, &c_b61, &c_b61, 31L);
    *istate = -8;
    return 0;
 

L565:
    xerrwv_("lsodi--  initialisation failed dy/dt:  routine", &c__50, &c__208,
	     &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 46L);
    xerrwv_("      of residue evaluation returns:", &c__50, &c__208, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 36L);
    xerrwv_("       ires = (i1)", &c__20, &c__208, &c__1, &c__1, &ier, &c__0, 
	    &c__0, &c_b61, &c_b61, 18L);
    *istate = -8;
    return 0;
 

L570:
    big = 0.;
    imxer = 1;
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	size = (d__1 = rwork[i__ + (ls0001_._3) .lacor - 1] * rwork[i__ + 
		(ls0001_._3) .lewt - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (big >= size) {
	    goto L575;
	}
	big = size;
	imxer = i__;
L575:
	;
    }
    iwork[16] = imxer;
 

L580:
    lyd0 = (ls0001_._3) .lyh + (ls0001_._3) .nyh;
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	rwork[i__ + (ls0001_._3) .lsavr - 1] = rwork[i__ + lyd0 - 1] / 
		(ls0001_._3) .h__;
 
	y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1];
    }
    ires = 1;
    (*res)(&neq[1], & (ls0001_._3) .tn, &y[1], &rwork[(ls0001_._3) .lsavr], &ydoti[1], &
	    ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._3) .nre;
    if (ires <= 1) {
	goto L595;
    }
    xerrwv_("lsodi--  routine for evaluation od residue returns", &c__50, &
	    c__210, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 50L);
    xerrwv_("    ires=i1 ", &c__50, &c__210, &c__1, &c__1, &ires, &c__0, &
	    c__0, &c_b61, &c_b61, 12L);
    goto L595;
 

L590:
    i__1 = (ls0001_._3) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = rwork[i__ + (ls0001_._3) .lyh - 1];
    }
L595:
    *t = (ls0001_._3) .tn;
    (ls0001_._3) .illin = 0;
    rwork[11] = (ls0001_._3) .hu;
    rwork[12] = (ls0001_._3) .h__;
    rwork[13] = (ls0001_._3) .tn;
    iwork[11] = (ls0001_._3) .nst;
    iwork[12] = (ls0001_._3) .nre;
    iwork[13] = (ls0001_._3) .nje;
    iwork[14] = (ls0001_._3) .nqu;
    iwork[15] = (ls0001_._3) .nq;
    return 0;
 

 
 
 
 
 
 
 

L601:
    xerrwv_("lsodi--  istate (=i1) illegal ", &c__30, &c__1, &c__1, &c__1, 
	    istate, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L602:
    xerrwv_("lsodi--  itask (=i1) illegal  ", &c__30, &c__2, &c__1, &c__1, 
	    itask, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L603:
    xerrwv_("lsodi--  istate .gt. 1 ", &c__50, &c__3, &c__1, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 23L);
    goto L700;
L604:
    xerrwv_("lsodi--  neq (=i1) .lt. 1     ", &c__30, &c__4, &c__1, &c__1, &
	    neq[1], &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L605:
    xerrwv_("lsodi--  istate = 3 et neq jumps from i1 to i2", &c__50, &c__5, &
	    c__1, &c__2, & (ls0001_._3) .n, &neq[1], &c__0, &c_b61, &c_b61, 46L);
    goto L700;
L606:
    xerrwv_("lsodi--  itol (=i1) illegal   ", &c__30, &c__6, &c__1, &c__1, 
	    itol, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L607:
    xerrwv_("lsodi--  iopt (=i1) illegal   ", &c__30, &c__7, &c__1, &c__1, 
	    iopt, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L608:
    xerrwv_("lsodi--  mf (=i1) illegal     ", &c__30, &c__8, &c__1, &c__1, mf,
	     &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L609:
    xerrwv_("lsodi--  ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__9, &c__1, &c__2, &ml, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L610:
    xerrwv_("lsodi--  mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)", &c__50, &
	    c__10, &c__1, &c__2, &mu, &neq[1], &c__0, &c_b61, &c_b61, 50L);
    goto L700;
L611:
    xerrwv_("lsodi--  maxord (=i1) .lt. 0  ", &c__30, &c__11, &c__1, &c__1, &
	    (ls0001_._3) .maxord, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L612:
    xerrwv_("lsodi--  mxstep (=i1) .lt. 0  ", &c__30, &c__12, &c__1, &c__1, &
	    (ls0001_._3) .mxstep, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L613:
    xerrwv_("lsodi--  mxhnil (=i1) .lt. 0  ", &c__30, &c__13, &c__1, &c__1, &
	    (ls0001_._3) .mxhnil, &c__0, &c__0, &c_b61, &c_b61, 30L);
    goto L700;
L614:
    xerrwv_("lsodi--  tout (=r1)  .gt.  t (=r2)      ", &c__40, &c__14, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    xerrwv_("      h0 (=r1) gives integration direction", &c__50, &c__14, &
	    c__1, &c__0, &c__0, &c__0, &c__1, &h0, &c_b61, 42L);
    goto L700;
L615:
    xerrwv_("lsodi--  hmax (=r1) .lt. 0.0  ", &c__30, &c__15, &c__1, &c__0, &
	    c__0, &c__0, &c__1, &hmax, &c_b61, 30L);
    goto L700;
L616:
    xerrwv_("lsodi--  hmin (=r1) .lt. 0.0  ", &c__30, &c__16, &c__1, &c__0, &
	    c__0, &c__0, &c__1, & (ls0001_._3) .hmin, &c_b61, 30L);
    goto L700;
L617:
    xerrwv_("lsodi-- necessary size for  rwork (i1) larger than i2", &c__60, &
	    c__17, &c__1, &c__2, &lenrw, lrw, &c__0, &c_b61, &c_b61, 53L);
    goto L700;
L618:
    xerrwv_("lsodi-- necessary size for  iwork (i1) larger than i2", &c__60, &
	    c__18, &c__1, &c__2, &leniw, liw, &c__0, &c_b61, &c_b61, 53L);
    goto L700;
L619:
    xerrwv_("lsodi--  rtol(i1) is r1 .lt. 0.0        ", &c__40, &c__19, &c__1,
	     &c__1, &i__, &c__0, &c__1, &rtoli, &c_b61, 40L);
    goto L700;
L620:
    xerrwv_("lsodi--  atol(i1) is r1 .lt. 0.0        ", &c__40, &c__20, &c__1,
	     &c__1, &i__, &c__0, &c__1, &atoli, &c_b61, 40L);
    goto L700;
L621:
    ewti = rwork[(ls0001_._3) .lewt + i__ - 1];
    xerrwv_("lsodi--  ewt(i1) (=r1) is  .le. 0.0         ", &c__40, &c__21, &
	    c__1, &c__1, &i__, &c__0, &c__1, &ewti, &c_b61, 44L);
    goto L700;
L622:
    xerrwv_("lsodi--  tout (=r1) too close to t(=r2) ", &c__60, &c__22, &c__1,
	     &c__0, &c__0, &c__0, &c__2, tout, t, 40L);
    goto L700;
L623:
    xerrwv_("lsodi--  itask = i1 and tout (=r1) .gt. tcur - hu (= r2)  ", &
	    c__60, &c__23, &c__1, &c__1, itask, &c__0, &c__2, tout, &tp, 58L);
    goto L700;
L624:
    xerrwv_("lsodi--  itask = 4 or 5 and tcrit (=r1) .gt. tcur (=r2)   ", &
	    c__60, &c__24, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, &
	    (ls0001_._3) .tn, 58L);
    goto L700;
L625:
    xerrwv_("lsodi--  itask = 4 or 5 and tcrit (=r1)  .gt.  tout (=r2)", &
	    c__60, &c__25, &c__1, &c__0, &c__0, &c__0, &c__2, &tcrit, tout, 
	    57L);
    goto L700;
L626:
    xerrwv_("lsodi-- too much accuracy required", &c__50, &c__26, &c__1, &
	    c__0, &c__0, &c__0, &c__0, &c_b61, &c_b61, 34L);
    xerrwv_("w.r.t machine precision tolsf (=r1)", &c__60, &c__26, &c__1, &
	    c__0, &c__0, &c__0, &c__1, &tolsf, &c_b61, 35L);
    rwork[14] = tolsf;
    goto L700;
L627:
    xerrwv_("lsodi--  problems due to intdy. itask=i1,tout=r1", &c__50, &
	    c__27, &c__1, &c__1, itask, &c__0, &c__1, tout, &c_b61, 48L);

L700:
    if ((ls0001_._3) .illin == 5) {
	goto L710;
    }
    ++ (ls0001_._3) .illin;
    *istate = -3;
    return 0;
L710:
    xerrwv_("lsodi--  incorrect inputs", &c__50, &c__302, &c__1, &c__0, &c__0,
	     &c__0, &c__0, &c_b61, &c_b61, 25L);

L800:
    xerrwv_("lsodi-- infinite loop", &c__50, &c__303, &c__2, &c__0, &c__0, &
	    c__0, &c__0, &c_b61, &c_b61, 21L);
    return 0;
 

}  

 
  int order_(limit, last, maxerr, ermax, elist, iord, liord, 
	nrmax)
integer *limit, *last, *maxerr;
doublereal *ermax, *elist;
integer *iord, *liord, *nrmax;
{
     
    integer i__1;

     
    static integer ibeg, jbnd, i__, j, k, isucc;
    static doublereal errmin, errmax;
    static integer ido;
     
    --elist;
    --iord;

     
    if (*last > 2) {
	goto L20;
    }
    iord[1] = 1;
    iord[2] = 2;
    goto L180;

L20:
    errmax = elist[*maxerr];
    if (*nrmax == 1) {
	goto L60;
    }
    ido = *nrmax - 1;
    i__1 = ido;
    for (i__ = 1; i__ <= i__1; ++i__) {
	isucc = iord[*nrmax - 1];
	if (errmax <= elist[isucc]) {
	    goto L60;
	}
	iord[*nrmax] = isucc;
	--(*nrmax);
 
    }

 
 
 
 

L60:
    dqa001_ .jupbnd = *last;
    if (*last > *limit / 2 + 2) {
	dqa001_ .jupbnd = *limit + 3 - *last;
    }
    errmin = elist[*last];

 
 
 

    jbnd = dqa001_ .jupbnd - 1;
    ibeg = *nrmax + 1;
    if (ibeg > jbnd) {
	goto L100;
    }
    i__1 = jbnd;
    for (i__ = ibeg; i__ <= i__1; ++i__) {
	isucc = iord[i__];
	if (errmax >= elist[isucc]) {
	    goto L120;
	}
	iord[i__ - 1] = isucc;
 
    }
L100:
    iord[jbnd] = *maxerr;
    iord[dqa001_ .jupbnd] = *last;
    goto L180;

 

L120:
    iord[i__ - 1] = *maxerr;
    k = jbnd;
    i__1 = jbnd;
    for (j = i__; j <= i__1; ++j) {
	isucc = iord[k];
	if (errmin < elist[isucc]) {
	    goto L160;
	}
	iord[k + 1] = isucc;
	--k;
 
    }
    iord[i__] = *last;
    goto L180;
L160:
    iord[k + 1] = *last;

 

L180:
    *maxerr = iord[*nrmax];
    *ermax = elist[*maxerr];
    return 0;
}  

 
  int prepj_(neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, f, jac)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *ewt, *ftem, *savf, *wm;
integer *iwm;
  int (*f) (), (*jac) ();
{
     
    integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

     
    static integer lenp;
    static doublereal srur;
    extern   int dgbfa_(), dgefa_();
    static integer i__, j, mband;
    static doublereal r__;
    static integer i1, i2, j1;
    extern doublereal vnorm_();
    static doublereal r0, di;
    static integer ii, jj, meband, ml, mu;
    static doublereal yi, yj, hl0;
    static integer ml3;
    static doublereal fac;
    static integer mba, ier;
    static doublereal con, yjj;
    static integer meb1;

 
 

 
 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

     
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --ewt;
    --ftem;
    --savf;
    --wm;
    --iwm;

     
    ++ (ls0001_._1) .nje;
    (ls0001_._1) .ierpj = 0;
    (ls0001_._1) .jcur = 1;
    hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0;
    switch ((int)(ls0001_._1) .miter) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L500;
    }
 

L100:
    lenp = (ls0001_._1) .n * (ls0001_._1) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._1) .n);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L240;
 

L200:
    fac = vnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]);
    r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ ))  * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n *
	     fac;
    if (r0 == 0.) {
	r0 = 1.;
    }
    srur = wm[1];
    j1 = 2;
    i__1 = (ls0001_._1) .n;
    for (j = 1; j <= i__1; ++j) {
	yj = y[j];
 
	d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = r0 / ewt[j];
	r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	y[j] += r__;
	fac = -hl0 / r__;
	(*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	i__2 = (ls0001_._1) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    wm[i__ + j1] = (ftem[i__] - savf[i__]) * fac;
	}
	y[j] = yj;
	j1 += (ls0001_._1) .n;
 
    }
    (ls0001_._1) .nfe += (ls0001_._1) .n;
 

L240:
    j = 3;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	wm[j] += 1.;
 
	j += (ls0001_._1) .n + 1;
    }
 

    dgefa_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._1) .ierpj = 1;
    }
    return 0;
 

L300:
    wm[2] = hl0;
    r__ = (ls0001_._1) .el0 * .1;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] += r__ * ((ls0001_._1) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)]);
    }
    (*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &wm[3]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._1) .nfe;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	r0 = (ls0001_._1) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)];
	di = r0 * .1 - (ls0001_._1) .h__ * (wm[i__ + 2] - savf[i__]);
	wm[i__ + 2] = 1.;
	if ((( r0 ) >= 0 ? ( r0 ) : -( r0 ))  < (ls0001_._1) .uround / ewt[i__]) {
	    goto L320;
	}
	if ((( di ) >= 0 ? ( di ) : -( di ))  == 0.) {
	    goto L330;
	}
	wm[i__ + 2] = r0 * .1 / di;
L320:
	;
    }
    return 0;
L330:
    (ls0001_._1) .ierpj = 1;
    return 0;
 

L400:
    ml = iwm[1];
    mu = iwm[2];
 
 
    ml3 = 3;
 
    mband = ml + mu + 1;
    meband = mband + ml;
    lenp = meband * (ls0001_._1) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &ml, &mu, &wm[ml3], &meband);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L570;
 

L500:
    ml = iwm[1];
    mu = iwm[2];
    mband = ml + mu + 1;
    mba = (( mband ) <= ( (ls0001_._1) .n ) ? ( mband ) : ( (ls0001_._1) .n )) ;
    meband = mband + ml;
    meb1 = meband - 1;
    srur = wm[1];
    fac = vnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]);
    r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ ))  * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n *
	     fac;
    if (r0 == 0.) {
	r0 = 1.;
    }
    i__1 = mba;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (ls0001_._1) .n;
	i__3 = mband;
	for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) {
	    yi = y[i__];
 
	    d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = r0 / ewt[i__];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	    y[i__] += r__;
	}
	(*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	i__3 = (ls0001_._1) .n;
	i__2 = mband;
	for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) {
	    y[jj] = yh[jj + yh_dim1];
	    yjj = y[jj];
 
	    d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = r0 / ewt[jj];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    fac = -hl0 / r__;
 
	    i__4 = jj - mu;
	    i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ;
 
	    i__4 = jj + ml;
	    i2 = (( i__4 ) <= ( (ls0001_._1) .n ) ? ( i__4 ) : ( (ls0001_._1) .n )) ;
	    ii = jj * meb1 - ml + 2;
	    i__4 = i2;
	    for (i__ = i1; i__ <= i__4; ++i__) {
 
		wm[ii + i__] = (ftem[i__] - savf[i__]) * fac;
	    }
 
	}
 
    }
    (ls0001_._1) .nfe += mba;
 

L570:
    ii = mband + 2;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	wm[ii] += 1.;
 
	ii += meband;
    }
 

    dgbfa_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._1) .ierpj = 1;
    }
    return 0;
 

}  

 
  int prepji_(neq, y, yh, nyh, ewt, rtem, savr, s, wm, iwm, 
	res, jac, adda)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *ewt, *rtem, *savr, *s, *wm;
integer *iwm;
  int (*res) (), (*jac) (), (*adda) ();
{
     
    integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

     
    static integer lenp, ires;
    static doublereal srur;
    extern   int dgbfa_(), dgefa_();
    static integer i__, j, mband;
    static doublereal r__;
    static integer i1, i2, j1, ii, jj, meband, ml, mu;
    static doublereal yi, yj, hl0;
    static integer ml3;
    static doublereal fac;
    static integer mba, ier;
    static doublereal con, yjj;
    static integer meb1;
     
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --ewt;
    --rtem;
    --savr;
    --s;
    --wm;
    --iwm;

     
    ++ (ls0001_._4) .nje;
    hl0 = (ls0001_._4) .h__ * (ls0001_._4) .el0;
    (ls0001_._4) .ierpj = 0;
    (ls0001_._4) .jcur = 1;
    switch ((int)(ls0001_._4) .miter) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L500;
    }
 

L100:
    ires = 1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
    lenp = (ls0001_._4) .n * (ls0001_._4) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &c__0, &c__0, &wm[3], &
	    (ls0001_._4) .n);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L240;
 

L200:
    ires = -1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
    srur = wm[1];
    j1 = 2;
    i__1 = (ls0001_._4) .n;
    for (j = 1; j <= i__1; ++j) {
	yj = y[j];
 
	d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = .01 / ewt[j];
	r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	y[j] += r__;
	fac = -hl0 / r__;
	(*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &rtem[1], &ires);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	++ (ls0001_._4) .nre;
	if (ires > 1) {
	    goto L600;
	}
	i__2 = (ls0001_._4) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    wm[i__ + j1] = (rtem[i__] - savr[i__]) * fac;
	}
	y[j] = yj;
	j1 += (ls0001_._4) .n;
 
    }
    ires = 1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
 

L240:
    (*adda)(&neq[1], & (ls0001_._4) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._4) .n);
    if (ierode_ .iero > 0) {
	return 0;
    }
 

    dgefa_(&wm[3], & (ls0001_._4) .n, & (ls0001_._4) .n, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._4) .ierpj = 1;
    }
    return 0;
 
L300:
    return 0;
 

L400:
    ires = 1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
    ml = iwm[1];
    mu = iwm[2];
 
 
    ml3 = 3;
 
    mband = ml + mu + 1;
    meband = mband + ml;
    lenp = meband * (ls0001_._4) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &ml, &mu, &wm[ml3], &meband);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L570;
 

L500:
    ires = -1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
    ml = iwm[1];
    mu = iwm[2];
    ml3 = ml + 3;
    mband = ml + mu + 1;
    mba = (( mband ) <= ( (ls0001_._4) .n ) ? ( mband ) : ( (ls0001_._4) .n )) ;
    meband = mband + ml;
    meb1 = meband - 1;
    srur = wm[1];
    i__1 = mba;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (ls0001_._4) .n;
	i__3 = mband;
	for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) {
	    yi = y[i__];
 
	    d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = .01 / ewt[i__];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	    y[i__] += r__;
	}
	(*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &rtem[1], &ires);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	++ (ls0001_._4) .nre;
	if (ires > 1) {
	    goto L600;
	}
	i__3 = (ls0001_._4) .n;
	i__2 = mband;
	for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) {
	    y[jj] = yh[jj + yh_dim1];
	    yjj = y[jj];
 
	    d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = .01 / ewt[jj];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    fac = -hl0 / r__;
 
	    i__4 = jj - mu;
	    i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ;
 
	    i__4 = jj + ml;
	    i2 = (( i__4 ) <= ( (ls0001_._4) .n ) ? ( i__4 ) : ( (ls0001_._4) .n )) ;
	    ii = jj * meb1 - ml + 2;
	    i__4 = i2;
	    for (i__ = i1; i__ <= i__4; ++i__) {
 
		wm[ii + i__] = (rtem[i__] - savr[i__]) * fac;
	    }
 
	}
 
    }
    ires = 1;
    (*res)(&neq[1], & (ls0001_._4) .tn, &y[1], &s[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._4) .nre;
    if (ires > 1) {
	goto L600;
    }
 

L570:
    (*adda)(&neq[1], & (ls0001_._4) .tn, &y[1], &ml, &mu, &wm[ml3], &meband);
    if (ierode_ .iero > 0) {
	return 0;
    }
 

    dgbfa_(&wm[3], &meband, & (ls0001_._4) .n, &ml, &mu, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._4) .ierpj = 1;
    }
    return 0;
 

L600:
    (ls0001_._4) .ierpj = ires;
    return 0;
 

}  

 
  int prja_(neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, f, jac)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *ewt, *ftem, *savf, *wm;
integer *iwm;
  int (*f) (), (*jac) ();
{
     
    integer yh_dim1, yh_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

     
    static integer lenp;
    static doublereal srur;
    extern   int dgbfa_(), dgefa_();
    static integer i__, j, mband;
    static doublereal r__;
    extern doublereal bnorm_(), fnorm_();
    static integer i1, i2, j1;
    static doublereal r0;
    static integer ii, jj, meband, ml, mu;
    static doublereal yi, yj, hl0;
    static integer ml3;
    extern doublereal vmnorm_();
    static doublereal fac;
    static integer mba, ier;
    static doublereal con, yjj;
    static integer meb1;
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --ewt;
    --ftem;
    --savf;
    --wm;
    --iwm;

     
    ++ (ls0001_._1) .nje;
    (ls0001_._1) .ierpj = 0;
    (ls0001_._1) .jcur = 1;
    hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0;
    switch ((int)(ls0001_._1) .miter) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L500;
    }
 

L100:
    lenp = (ls0001_._1) .n * (ls0001_._1) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &c__0, &c__0, &wm[3], & (ls0001_._1) .n);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L240;
 

L200:
    fac = vmnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]);
    r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ ))  * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n *
	     fac;
    if (r0 == 0.) {
	r0 = 1.;
    }
    srur = wm[1];
    j1 = 2;
    i__1 = (ls0001_._1) .n;
    for (j = 1; j <= i__1; ++j) {
	yj = y[j];
 
	d__1 = srur * (( yj ) >= 0 ? ( yj ) : -( yj )) , d__2 = r0 / ewt[j];
	r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	y[j] += r__;
	fac = -hl0 / r__;
	(*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	i__2 = (ls0001_._1) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    wm[i__ + j1] = (ftem[i__] - savf[i__]) * fac;
	}
	y[j] = yj;
	j1 += (ls0001_._1) .n;
 
    }
    (ls0001_._1) .nfe += (ls0001_._1) .n;
L240:
 

    (lsa001_._2) .pdnorm = fnorm_(& (ls0001_._1) .n, &wm[3], &ewt[1]) / (( hl0 ) >= 0 ? ( hl0 ) : -( hl0 )) ;
 

    j = 3;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	wm[j] += 1.;
 
	j += (ls0001_._1) .n + 1;
    }
 

    dgefa_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._1) .ierpj = 1;
    }
    return 0;
 

L300:
    return 0;
 

L400:
    ml = iwm[1];
    mu = iwm[2];
    ml3 = ml + 3;
    mband = ml + mu + 1;
    meband = mband + ml;
    lenp = meband * (ls0001_._1) .n;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] = 0.;
    }
    (*jac)(&neq[1], & (ls0001_._1) .tn, &y[1], &ml, &mu, &wm[ml3], &meband);
    if (ierode_ .iero > 0) {
	return 0;
    }
    con = -hl0;
    i__1 = lenp;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	wm[i__ + 2] *= con;
    }
    goto L570;
 

L500:
    ml = iwm[1];
    mu = iwm[2];
    mband = ml + mu + 1;
    mba = (( mband ) <= ( (ls0001_._1) .n ) ? ( mband ) : ( (ls0001_._1) .n )) ;
    meband = mband + ml;
    meb1 = meband - 1;
    srur = wm[1];
    fac = vmnorm_(& (ls0001_._1) .n, &savf[1], &ewt[1]);
    r0 = (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ ))  * 1e3 * (ls0001_._1) .uround * (doublereal) (ls0001_._1) .n *
	     fac;
    if (r0 == 0.) {
	r0 = 1.;
    }
    i__1 = mba;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (ls0001_._1) .n;
	i__3 = mband;
	for (i__ = j; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) {
	    yi = y[i__];
 
	    d__1 = srur * (( yi ) >= 0 ? ( yi ) : -( yi )) , d__2 = r0 / ewt[i__];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	    y[i__] += r__;
	}
	(*f)(&neq[1], & (ls0001_._1) .tn, &y[1], &ftem[1]);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	i__3 = (ls0001_._1) .n;
	i__2 = mband;
	for (jj = j; i__2 < 0 ? jj >= i__3 : jj <= i__3; jj += i__2) {
	    y[jj] = yh[jj + yh_dim1];
	    yjj = y[jj];
 
	    d__1 = srur * (( yjj ) >= 0 ? ( yjj ) : -( yjj )) , d__2 = r0 / ewt[jj];
	    r__ = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    fac = -hl0 / r__;
 
	    i__4 = jj - mu;
	    i1 = (( i__4 ) >= ( 1 ) ? ( i__4 ) : ( 1 )) ;
 
	    i__4 = jj + ml;
	    i2 = (( i__4 ) <= ( (ls0001_._1) .n ) ? ( i__4 ) : ( (ls0001_._1) .n )) ;
	    ii = jj * meb1 - ml + 2;
	    i__4 = i2;
	    for (i__ = i1; i__ <= i__4; ++i__) {
 
		wm[ii + i__] = (ftem[i__] - savf[i__]) * fac;
	    }
 
	}
 
    }
    (ls0001_._1) .nfe += mba;
L570:
 

    (lsa001_._2) .pdnorm = bnorm_(& (ls0001_._1) .n, &wm[3], &meband, &ml, &mu, &ewt[1]) 
	    / (( hl0 ) >= 0 ? ( hl0 ) : -( hl0 )) ;
 

    ii = mband + 2;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	wm[ii] += 1.;
 
	ii += meband;
    }
 

    dgbfa_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &ier);
    if (ier != 0) {
	(ls0001_._1) .ierpj = 1;
    }
    return 0;
 

}  

 
  int quarul_(f, a, b, result, abserr, resabs, resasc)
doublereal (*f) ();
doublereal *a, *b, *result, *abserr, *resabs, *resasc;
{
     

    static doublereal xgk[11] = { .9956571630258080807355272807,
	    .9739065285171717200779640121,.9301574913557082260012071801,
	    .8650633666889845107320966884,.7808177265864168970637175783,
	    .6794095682990244062343273651,.5627571346686046833390000993,
	    .4333953941292471907992659432,.2943928627014601981311266031,
	    .1488743389816312108848260011,0. };
    static doublereal wgk[11] = { .01169463886737187427806439606,
	    .03255816230796472747881897246,.05475589657435199603138130024,
	    .07503967481091995276704314092,.09312545458369760553506546508,
	    .1093871588022976418992105903,.1234919762620658510779581098,
	    .1347092173114733259280540018,.1427759385770600807970942731,
	    .147739104901338491374841516,.1494455540029169056649364684 };
    static doublereal wg[10] = { 0.,.06667134430868813759356880989,0.,
	    .1494513491505805931457763397,0.,.2190863625159820439955349342,0.,
	    .2692667193099963550912269216,0.,.2955242247147528701738929947 };

     
    doublereal d__1, d__2, d__3;

     
    double pow_dd();

     
    static doublereal absc, resg, resk, fsum, fval1, fval2;
    static integer j;
    static doublereal hlgth, reskh, uflow, fc;
    extern doublereal dlamch_();
    static doublereal epmach, dhlgth, centre, fv1[10], fv2[10];
    epmach = dlamch_("p", 1L);
    uflow = dlamch_("u", 1L);
    centre = (*a + *b) * .5;
    hlgth = (*b - *a) * .5;
    dhlgth = (( hlgth ) >= 0 ? ( hlgth ) : -( hlgth )) ;

 
 

    resg = 0.;
    fc = (*f)(&centre);
    if (ierajf_ .iero != 0) {
	return 0;
    }
    resk = wgk[10] * fc;
    *resabs = (( resk ) >= 0 ? ( resk ) : -( resk )) ;
    for (j = 1; j <= 10; ++j) {
	absc = hlgth * xgk[j - 1];
	d__1 = centre - absc;
	fval1 = (*f)(&d__1);
	if (ierajf_ .iero != 0) {
	    return 0;
	}
	d__1 = centre + absc;
	fval2 = (*f)(&d__1);
	if (ierajf_ .iero != 0) {
	    return 0;
	}
	fv1[j - 1] = fval1;
	fv2[j - 1] = fval2;
	fsum = fval1 + fval2;
	resg += wg[j - 1] * fsum;
	resk += wgk[j - 1] * fsum;
	*resabs += wgk[j - 1] * ((( fval1 ) >= 0 ? ( fval1 ) : -( fval1 ))  + (( fval2 ) >= 0 ? ( fval2 ) : -( fval2 )) );
 
    }
    reskh = resk * .5;
    *resasc = wgk[10] * (d__1 = fc - reskh, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    for (j = 1; j <= 10; ++j) {
	*resasc += wgk[j - 1] * ((d__1 = fv1[j - 1] - reskh, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (
		d__2 = fv2[j - 1] - reskh, (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ));
 
    }
    *result = resk * hlgth;
    *resabs *= dhlgth;
    *resasc *= dhlgth;
    *abserr = (d__1 = (resk - resg) * hlgth, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    if (*resasc != 0. && *abserr != 0.) {
 
	d__3 = *abserr * 200. / *resasc;
	d__1 = 1., d__2 = pow_dd(&d__3, &c_b5310);
	*abserr = *resasc * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if (*resabs > uflow / (epmach * 50.)) {
 
	d__1 = epmach * *resabs * 50.;
	*abserr = (( d__1 ) >= ( *abserr ) ? ( d__1 ) : ( *abserr )) ;
    }
    return 0;
}  

  int rchek_(job, g, neq, y, yh, nyh, g0, g1, gx, jroot, irt)
integer *job;
  int (*g) ();
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *g0, *g1, *gx;
integer *jroot, *irt;
{
     
    integer yh_dim1, yh_offset, i__1;
    doublereal d__1;

     
    double d_sign();

     
    static doublereal temp1, temp2;
    static integer i__, iflag, jflag;
    static doublereal x, hming;
    extern   int dcopy_(), intdy_();
    static doublereal t1;
    extern   int roots_();
    static logical zroot;
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --g0;
    --g1;
    --gx;
    --jroot;

     
    *irt = 0;
    i__1 = (lsr001_._2) .ngc;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	jroot[i__] = 0;
    }
    hming = ((( (ls0001_._1) .tn ) >= 0 ? ( (ls0001_._1) .tn ) : -( (ls0001_._1) .tn ))  + (( (ls0001_._1) .h__ ) >= 0 ? ( (ls0001_._1) .h__ ) : -( (ls0001_._1) .h__ )) ) * (ls0001_._1) .uround * 100.;

    switch ((int)*job) {
	case 1:  goto L100;
	case 2:  goto L200;
	case 3:  goto L300;
    }

 

L100:
    (lsr001_._2) .t0 = (ls0001_._1) .tn;
    (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    (lsr001_._2) .nge = 1;
    zroot = (0) ;
    i__1 = (lsr001_._2) .ngc;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) {
	    zroot = (1) ;
	}
    }
    if (! zroot) {
	goto L190;
    }
 

    temp1 = d_sign(&hming, & (ls0001_._1) .h__);
    (lsr001_._2) .t0 += temp1;
    temp2 = temp1 / (ls0001_._1) .h__;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] += temp2 * yh[i__ + (yh_dim1 << 1)];
    }
    (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (lsr001_._2) .nge;
    zroot = (0) ;
    i__1 = (lsr001_._2) .ngc;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) {
	    zroot = (1) ;
	}
    }
    if (! zroot) {
	goto L190;
    }
 

    *irt = -1;
    return 0;

L190:
    return 0;


L200:
    if ((lsr001_._2) .irfnd == 0) {
	goto L260;
    }
 

    intdy_(& (lsr001_._2) .t0, &c__0, &yh[yh_offset], nyh, &y[1], &iflag);
    (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (lsr001_._2) .nge;
    zroot = (0) ;
    i__1 = (lsr001_._2) .ngc;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 0.) {
	    zroot = (1) ;
	}
    }
    if (! zroot) {
	goto L260;
    }
 

    temp1 = d_sign(&hming, & (ls0001_._1) .h__);
    (lsr001_._2) .t0 += temp1;
    if (((lsr001_._2) .t0 - (ls0001_._1) .tn) * (ls0001_._1) .h__ < 0.) {
	goto L230;
    }
    temp2 = temp1 / (ls0001_._1) .h__;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] += temp2 * yh[i__ + (yh_dim1 << 1)];
    }
    goto L240;
L230:
    intdy_(& (lsr001_._2) .t0, &c__0, &yh[yh_offset], nyh, &y[1], &iflag);
L240:
    (*g)(&neq[1], & (lsr001_._2) .t0, &y[1], & (lsr001_._2) .ngc, &g0[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (lsr001_._2) .nge;
    zroot = (0) ;
    i__1 = (lsr001_._2) .ngc;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = g0[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > 0.) {
	    goto L250;
	}
	jroot[i__] = 1;
	zroot = (1) ;
L250:
	;
    }
    if (! zroot) {
	goto L260;
    }
 

    *irt = 1;
    return 0;
 
 

L260:
    if ((ls0001_._1) .tn == (lsr001_._2) .tlast) {
	goto L390;
    }

L300:
 

    if ((lsr001_._2) .itaskc == 2 || (lsr001_._2) .itaskc == 3 || (lsr001_._2) .itaskc == 5) 
	    {
	goto L310;
    }
    if (((lsr001_._2) .toutc - (ls0001_._1) .tn) * (ls0001_._1) .h__ >= 0.) {
	goto L310;
    }
    t1 = (lsr001_._2) .toutc;
    if ((t1 - (lsr001_._2) .t0) * (ls0001_._1) .h__ <= 0.) {
	goto L390;
    }
    intdy_(&t1, &c__0, &yh[yh_offset], nyh, &y[1], &iflag);
    goto L330;
L310:
    t1 = (ls0001_._1) .tn;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = yh[i__ + yh_dim1];
    }
L330:
    (*g)(&neq[1], &t1, &y[1], & (lsr001_._2) .ngc, &g1[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (lsr001_._2) .nge;
 

    jflag = 0;
L350:
    roots_(& (lsr001_._2) .ngc, &hming, &jflag, & (lsr001_._2) .t0, &t1, &g0[1], &g1[1], &
	    gx[1], &x, &jroot[1]);
    if (jflag > 1) {
	goto L360;
    }
    intdy_(&x, &c__0, &yh[yh_offset], nyh, &y[1], &iflag);
    (*g)(&neq[1], &x, &y[1], & (lsr001_._2) .ngc, &gx[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (lsr001_._2) .nge;
    goto L350;
L360:
    (lsr001_._2) .t0 = x;
    dcopy_(& (lsr001_._2) .ngc, &gx[1], &c__1, &g0[1], &c__1);
    if (jflag == 4) {
	goto L390;
    }
 

    intdy_(&x, &c__0, &yh[yh_offset], nyh, &y[1], &iflag);
    *irt = 1;
    return 0;

L390:
    return 0;
 

}  

 
 
 
 
 
  int lsrgk_(f, neq, y, t, tout, itol, rtol, atol, itask, 
	istate, iopt, rwork, lrw, iwork, liw, jac, mf)
  int (*f) ();
integer *neq;
doublereal *y, *t, *tout;
integer *itol;
doublereal *rtol, *atol;
integer *itask, *istate, *iopt;
doublereal *rwork;
integer *lrw, *iwork, *liw;
  int (*jac) ();
integer *mf;
{
    static integer nbad;
    extern   int rkqc_();
    extern   int odeint_();
    static integer nok;

     
    --neq;
    --y;
    --rtol;
    --atol;
    --rwork;
    --iwork;

     
    ierode_ .iero = 0;
    odeint_(&y[1], &neq[1], t, tout, &atol[1], &c_b5340, &c_b61, &nok, &nbad, 
	    f, rkqc_);
    *t = *tout;
    if (ierode_ .iero > 0) {
	*istate = -1;
    }
    return 0;
}  

 
 
 
  int odeint_(ystart, nvar, x1, x2, eps, h1, hmin, nok, nbad, 
	derivs, rkqc)
doublereal *ystart;
integer *nvar;
doublereal *x1, *x2, *eps, *h1, *hmin;
integer *nok, *nbad;
  int (*derivs) (), (*rkqc) ();
{
     
    integer i__1;
    doublereal d__1, d__2;

     
    double d_sign();
    integer s_wsle(), do_lio(), e_wsle();

     
    static doublereal hdid, dydx[10], xsav;
    static integer nstp;
    static doublereal h__;
    static integer i__;
    static doublereal x, y[10], yscal[10], hnext;

     
    static cilist io___1589 = { 0, 6, 0, 0, 0 };
    static cilist io___1590 = { 0, 6, 0, 0, 0 };


 
     
    --ystart;

     
    ierode_ .iero = 0;
    if ((d__1 = *x2 - *x1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= 1e-30) {
	return 0;
    }
    x = *x1;
    d__1 = *x2 - *x1;
    h__ = d_sign(h1, &d__1);
    *nok = 0;
    *nbad = 0;
    path_ .kount = 0;
    i__1 = *nvar;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__ - 1] = ystart[i__];
 
    }
    xsav = x - path_ .dxsav * 2.;
    for (nstp = 1; nstp <= 10000; ++nstp) {
	(*derivs)(nvar, &x, y, dydx);
	if (ierode_ .iero > 0) {
	    return 0;
	}
	i__1 = *nvar;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    yscal[i__ - 1] = (d__1 = y[i__ - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = h__ * 
		    dydx[i__ - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + 1e-30;
 
	}
	if (path_ .kmax > 0) {
	    if ((d__1 = x - xsav, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (( path_ .dxsav ) >= 0 ? ( path_ .dxsav ) : -( path_ .dxsav )) ) {
		if (path_ .kount < path_ .kmax - 1) {
		    ++ path_ .kount;
		    path_ .xp[path_ .kount - 1] = x;
		    i__1 = *nvar;
		    for (i__ = 1; i__ <= i__1; ++i__) {
			path_ .yp[i__ + path_ .kount * 10 - 11] = y[i__ - 1];
 
		    }
		    xsav = x;
		}
	    }
	}
	if ((x + h__ - *x2) * (x + h__ - *x1) > 0.) {
	    h__ = *x2 - x;
	}
	(*rkqc)(y, dydx, nvar, &x, &h__, eps, yscal, &hdid, &hnext, derivs);
	if (hdid == h__) {
	    ++(*nok);
	} else {
	    ++(*nbad);
	}
	if ((x - *x2) * (*x2 - *x1) >= 0.) {
	    i__1 = *nvar;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		ystart[i__] = y[i__ - 1];
 
	    }
	    if (path_ .kmax != 0) {
		++ path_ .kount;
		path_ .xp[path_ .kount - 1] = x;
		i__1 = *nvar;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    path_ .yp[i__ + path_ .kount * 10 - 11] = y[i__ - 1];
 
		}
	    }
	    return 0;
	}
	if ((( hnext ) >= 0 ? ( hnext ) : -( hnext ))  < *hmin) {
	    s_wsle(&io___1589);
	    do_lio(&c__9, &c__1, "stepsize", 8L);
	    do_lio(&c__5, &c__1, (char *)&hnext, (ftnlen)sizeof(doublereal));
	    do_lio(&c__9, &c__1, " smaller than minimum.", 22L);
	    e_wsle();
	}
	h__ = hnext;
 
    }
    s_wsle(&io___1590);
    do_lio(&c__9, &c__1, "Trop d'iterations a faire pour la precision demandee.", 53L);
    e_wsle();
    return 0;
}  

  int rk4_(y, dydx, n, x, h__, yout, derivs)
doublereal *y, *dydx;
integer *n;
doublereal *x, *h__, *yout;
  int (*derivs) ();
{
     
    integer i__1;
    doublereal d__1;

     
    static integer i__;
    static doublereal h6, hh, xh, yt[10], dym[10], dyt[10];

 
     
    --yout;
    --dydx;
    --y;

     
    ierode_ .iero = 0;
    hh = *h__ * (float).5;
    h6 = *h__ / (float)6.;
    xh = *x + hh;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yt[i__ - 1] = y[i__] + hh * dydx[i__];
 
    }
    (*derivs)(n, &xh, yt, dyt);
    if (ierode_ .iero > 0) {
	return 0;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yt[i__ - 1] = y[i__] + hh * dyt[i__ - 1];
 
    }
    (*derivs)(n, &xh, yt, dym);
    if (ierode_ .iero > 0) {
	return 0;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yt[i__ - 1] = y[i__] + *h__ * dym[i__ - 1];
	dym[i__ - 1] = dyt[i__ - 1] + dym[i__ - 1];
 
    }
    d__1 = *x + *h__;
    (*derivs)(n, &d__1, yt, dyt);
    if (ierode_ .iero > 0) {
	return 0;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	yout[i__] = y[i__] + h6 * (dydx[i__] + dyt[i__ - 1] + dym[i__ - 1] * (
		float)2.);
 
    }
    return 0;
}  

  int rkqc_(y, dydx, n, x, htry, eps, yscal, hdid, hnext, 
	derivs)
doublereal *y, *dydx;
integer *n;
doublereal *x, *htry, *eps, *yscal, *hdid, *hnext;
  int (*derivs) ();
{
     
    integer i__1;
    doublereal d__1, d__2, d__3;

     
    integer s_wsle(), do_lio(), e_wsle();
    double pow_dd();

     
    static doublereal xsav, ysav[10], h__;
    static integer i__;
    static doublereal dysav[10], pgrow, ytemp[10], hh, errmax, pshrnk;
    extern   int rk4_();

     
    static cilist io___1607 = { 0, 6, 0, 0, 0 };


 
     
    --yscal;
    --dydx;
    --y;

     
    ierode_ .iero = 0;
    pgrow = (float)-.2;
    pshrnk = (float)-.25;
    xsav = *x;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ysav[i__ - 1] = y[i__];
	dysav[i__ - 1] = dydx[i__];
 
    }
    h__ = *htry;
L1:
    hh = h__ * (float).5;
    rk4_(ysav, dysav, n, &xsav, &hh, ytemp, derivs);
    *x = xsav + hh;
    (*derivs)(n, x, ytemp, &dydx[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    rk4_(ytemp, &dydx[1], n, x, &hh, &y[1], derivs);
    *x = xsav + h__;
    if (*x == xsav) {
	s_wsle(&io___1607);
	do_lio(&c__9, &c__1, "stepsize not significant in rkqc.", 33L);
	e_wsle();
	ierode_ .iero = 1;
	return 0;
    }
    rk4_(ysav, dysav, n, &xsav, &h__, ytemp, derivs);
    errmax = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ytemp[i__ - 1] = y[i__] - ytemp[i__ - 1];
 
	d__2 = errmax, d__3 = (d__1 = ytemp[i__ - 1] / (yscal[i__] * *eps), 
		(( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	errmax = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
    }
    if (errmax > 1.) {
	h__ = h__ * .9 * pow_dd(&errmax, &pshrnk);
	goto L1;
    } else {
	*hdid = h__;
	if (errmax > 6e-4) {
	    *hnext = h__ * .9 * pow_dd(&errmax, &pgrow);
	} else {
	    *hnext = h__ * (float)4.;
	}
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[i__] += ytemp[i__ - 1] * .0666666667;
 
    }
    return 0;
}  

  int roots_(ng, hmin, jflag, x0, x1, g0, g1, gx, x, jroot)
integer *ng;
doublereal *hmin;
integer *jflag;
doublereal *x0, *x1, *g0, *g1, *gx, *x;
integer *jroot;
{
     

    static doublereal zero = 0.;

     
    integer i__1;
    doublereal d__1, d__2;

     
    double d_sign();

     
    static doublereal tmax;
    static integer i__;
    extern   int dcopy_();
    static doublereal t2;
    static logical xroot, zroot, sgnchg;
    static integer imxold, nxlast;
     
    --jroot;
    --gx;
    --g1;
    --g0;

     

    if (*jflag == 1) {
	goto L200;
    }
 

    (lsr001_._3) .imax = 0;
    tmax = zero;
    zroot = (0) ;
    i__1 = *ng;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) {
	    goto L110;
	}
	zroot = (1) ;
	goto L120;
 

L110:
	if (d_sign(&c_b89, &g0[i__]) == d_sign(&c_b89, &g1[i__])) {
	    goto L120;
	}
	t2 = (d__1 = g1[i__] / (g1[i__] - g0[i__]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (t2 <= tmax) {
	    goto L120;
	}
	tmax = t2;
	(lsr001_._3) .imax = i__;
L120:
	;
    }
    if ((lsr001_._3) .imax > 0) {
	goto L130;
    }
    sgnchg = (0) ;
    goto L140;
L130:
    sgnchg = (1) ;
L140:
    if (! sgnchg) {
	goto L400;
    }
 

    xroot = (0) ;
    nxlast = 0;
    (lsr001_._3) .last = 1;

 

L150:
    if (xroot) {
	goto L300;
    }
    if (nxlast == (lsr001_._3) .last) {
	goto L160;
    }
    (lsr001_._3) .alpha = 1.;
    goto L180;
L160:
    if ((lsr001_._3) .last == 0) {
	goto L170;
    }
    (lsr001_._3) .alpha *= .5;
    goto L180;
L170:
    (lsr001_._3) .alpha *= 2.;
L180:
    (lsr001_._3) .x2 = *x1 - (*x1 - *x0) * g1[(lsr001_._3) .imax] / (g1[(lsr001_._3) .imax] 
	    - (lsr001_._3) .alpha * g0[(lsr001_._3) .imax]);
    if ((d__1 = (lsr001_._3) .x2 - *x0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < *hmin && (d__2 = *x1 - *x0, 
	    (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) > *hmin * 10.) {
	(lsr001_._3) .x2 = *x0 + (*x1 - *x0) * .1;
    }
    *jflag = 1;
    *x = (lsr001_._3) .x2;
 

    return 0;
 

L200:
    imxold = (lsr001_._3) .imax;
    (lsr001_._3) .imax = 0;
    tmax = zero;
    zroot = (0) ;
    i__1 = *ng;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = gx[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) {
	    goto L210;
	}
	zroot = (1) ;
	goto L220;
 

L210:
	if (d_sign(&c_b89, &g0[i__]) == d_sign(&c_b89, &gx[i__])) {
	    goto L220;
	}
	t2 = (d__1 = gx[i__] / (gx[i__] - g0[i__]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (t2 <= tmax) {
	    goto L220;
	}
	tmax = t2;
	(lsr001_._3) .imax = i__;
L220:
	;
    }
    if ((lsr001_._3) .imax > 0) {
	goto L230;
    }
    sgnchg = (0) ;
    (lsr001_._3) .imax = imxold;
    goto L240;
L230:
    sgnchg = (1) ;
L240:
    nxlast = (lsr001_._3) .last;
    if (! sgnchg) {
	goto L250;
    }
 

    *x1 = (lsr001_._3) .x2;
    dcopy_(ng, &gx[1], &c__1, &g1[1], &c__1);
    (lsr001_._3) .last = 1;
    xroot = (0) ;
    goto L270;
L250:
    if (! zroot) {
	goto L260;
    }
 

    *x1 = (lsr001_._3) .x2;
    dcopy_(ng, &gx[1], &c__1, &g1[1], &c__1);
    xroot = (1) ;
    goto L270;
 

L260:
    dcopy_(ng, &gx[1], &c__1, &g0[1], &c__1);
    *x0 = (lsr001_._3) .x2;
    (lsr001_._3) .last = 0;
    xroot = (0) ;
L270:
    if ((d__1 = *x1 - *x0, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *hmin) {
	xroot = (1) ;
    }
    goto L150;

 

L300:
    *jflag = 2;
    *x = *x1;
    dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1);
    i__1 = *ng;
    for (i__ = 1; i__ <= i__1; ++i__) {
	jroot[i__] = 0;
	if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > zero) {
	    goto L310;
	}
	jroot[i__] = 1;
	goto L320;
L310:
	if (d_sign(&c_b89, &g0[i__]) != d_sign(&c_b89, &g1[i__])) {
	    jroot[i__] = 1;
	}
L320:
	;
    }
    return 0;

 

L400:
    if (! zroot) {
	goto L420;
    }

 

    *x = *x1;
    dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1);
    i__1 = *ng;
    for (i__ = 1; i__ <= i__1; ++i__) {
	jroot[i__] = 0;
	if ((d__1 = g1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= zero) {
	    jroot[i__] = 1;
	}
 
    }
    *jflag = 3;
    return 0;

 

L420:
    dcopy_(ng, &g1[1], &c__1, &gx[1], &c__1);
    *x = *x1;
    *jflag = 4;
    return 0;
 

}  

 
  int rscar1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;
    static integer lenrla = 22;
    static integer lenila = 9;
    static integer lenrlr = 5;
    static integer lenilr = 9;

     
    integer i__1;

     
    static integer i__, l;
    extern   int dcopy_();

 
 
 
 

 
 
     
    --isav;
    --rsav;

     

    l = 1;
    dcopy_(&lenrls, &rsav[l], &c__1, (ls0001_._5) .rls, &c__1);
    l += lenrls;
    dcopy_(&lenrla, &rsav[l], &c__1, (lsa001_._3) .rlsa, &c__1);
    l += lenrla;
    dcopy_(&lenrlr, &rsav[l], &c__1, (lsr001_._4) .rlsr, &c__1);

    l = 0;
    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
	(ls0001_._5) .ils[i__ - 1] = (integer) isav[l + i__];
 
    }
    l += lenils;
    i__1 = lenila;
    for (i__ = 1; i__ <= i__1; ++i__) {
	(lsa001_._3) .ilsa[i__ - 1] = (integer) isav[l + i__];
 
    }
    l += lenila;
    i__1 = lenilr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	(lsr001_._4) .ilsr[i__ - 1] = (integer) isav[l + i__];
 
    }
    l += lenilr;

    (eh0001_._1) .ieh[0] = (integer) isav[l + 1];
    (eh0001_._1) .ieh[1] = (integer) isav[l + 2];
    return 0;
}  

 
  int rscma1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;
    static integer lenrla = 22;
    static integer lenila = 9;

     
    integer i__1;

     
    static integer i__;

 
 
 
 

 
 
     
    --isav;
    --rsav;

     

    i__1 = lenrls;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._5) .rls[i__ - 1] = rsav[i__];
    }
    i__1 = lenrla;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(lsa001_._3) .rlsa[i__ - 1] = rsav[lenrls + i__];
    }

    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._5) .ils[i__ - 1] = (integer) isav[i__];
    }
    i__1 = lenila;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(lsa001_._3) .ilsa[i__ - 1] = (integer) isav[lenils + i__];
    }

    (eh0001_._1) .ieh[0] = (integer) isav[lenils + lenila + 1];
    (eh0001_._1) .ieh[1] = (integer) isav[lenils + lenila + 2];
    return 0;
}  

 
  int rscom1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;

     
    integer i__1;

     
    static integer i__;

 
 
 
 
 
 
     
    --isav;
    --rsav;

     

    i__1 = lenrls;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._5) .rls[i__ - 1] = rsav[i__];
    }
    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._5) .ils[i__ - 1] = (integer) isav[i__];
    }
    (eh0001_._1) .ieh[0] = (integer) isav[lenils + 1];
    (eh0001_._1) .ieh[1] = (integer) isav[lenils + 2];
    return 0;
}  

 
  int solsy_(wm, iwm, x, tem)
doublereal *wm;
integer *iwm;
doublereal *x, *tem;
{
     
    integer i__1;

     
    static integer i__;
    static doublereal r__;
    extern   int dgbsl_(), dgesl_();
    static doublereal di;
    static integer meband, ml, mu;
    static doublereal hl0, phl0;
    --tem;
    --x;
    --iwm;
    --wm;

     
    (ls0001_._1) .iersl = 0;
    switch ((int)(ls0001_._1) .miter) {
	case 1:  goto L100;
	case 2:  goto L100;
	case 3:  goto L300;
	case 4:  goto L400;
	case 5:  goto L400;
    }
L100:
    dgesl_(&wm[3], & (ls0001_._1) .n, & (ls0001_._1) .n, &iwm[21], &x[1], &c__0);
    return 0;

L300:
    phl0 = wm[2];
    hl0 = (ls0001_._1) .h__ * (ls0001_._1) .el0;
    wm[2] = hl0;
    if (hl0 == phl0) {
	goto L330;
    }
    r__ = hl0 / phl0;
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	di = 1. - r__ * (1. - 1. / wm[i__ + 2]);
	if ((( di ) >= 0 ? ( di ) : -( di ))  == 0.) {
	    goto L390;
	}
 
	wm[i__ + 2] = 1. / di;
    }
L330:
    i__1 = (ls0001_._1) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x[i__] = wm[i__ + 2] * x[i__];
    }
    return 0;
L390:
    (ls0001_._1) .iersl = 1;
    return 0;

L400:
    ml = iwm[1];
    mu = iwm[2];
    meband = (ml << 1) + mu + 1;
    dgbsl_(&wm[3], &meband, & (ls0001_._1) .n, &ml, &mu, &iwm[21], &x[1], &c__0);
    return 0;
 

}  

 
  int stoda_(neq, y, yh, nyh, yh1, ewt, savf, acor, wm, iwm, f,
	 jac, pjac, slvs)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *yh1, *ewt, *savf, *acor, *wm;
integer *iwm;
  int (*f) (), (*jac) (), (*pjac) (), (*slvs) ();
{
     

    static doublereal sm1[12] = { .5,.575,.55,.45,.35,.25,.2,.15,.1,.075,.05,
	    .025 };

     
    integer yh_dim1, yh_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    double pow_dd();

     
    static doublereal dcon, delp;
    static integer lm1p1, lm2p1;
    static doublereal exdn, rhdn;
    static integer iret;
    static doublereal told, rate, rhsm;
    static integer newq;
    static doublereal exsm, rhup, exup, rh1it;
    static integer i__, j, m;
    extern   int cfode_();
    static doublereal r__, alpha;
    static integer iredo, i1;
    static doublereal pnorm;
    static integer jb;
    static doublereal rh, rm, dm1, dm2;
    static integer lm1, lm2;
    extern doublereal vmnorm_();
    static doublereal rh1, rh2, del, ddn;
    static integer ncf;
    static doublereal pdh, dsm, dup, exm1, exm2;
    static integer nqm1, nqm2;

 
     
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --yh1;
    --ewt;
    --savf;
    --acor;
    --wm;
    --iwm;

     
 

 
 
 
 
 
 
 
 
 
 
 
 
 

    (ls0001_._6) .kflag = 0;
    told = (ls0001_._6) .tn;
    ncf = 0;
    (ls0001_._6) .ierpj = 0;
    (ls0001_._6) .iersl = 0;
    (ls0001_._6) .jcur = 0;
    (ls0001_._6) .icf = 0;
    if ((ls0001_._6) .jstart > 0) {
	goto L200;
    }
    if ((ls0001_._6) .jstart == -1) {
	goto L100;
    }
    if ((ls0001_._6) .jstart == -2) {
	goto L160;
    }
 

 
 
 
 
 
 
 
 

    (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1;
    (ls0001_._6) .nq = 1;
    (ls0001_._6) .l = 2;
    (ls0001_._6) .ialth = 2;
    (ls0001_._6) .rmax = 1e4;
    (ls0001_._6) .rc = 0.;
    (ls0001_._6) .el0 = 1.;
    (ls0001_._6) .crate = .7;
    delp = 0.;
    (ls0001_._6) .hold = (ls0001_._6) .h__;
    (ls0001_._6) .nslp = 0;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    iret = 3;
 

    (lsa001_._4) .icount = 20;
    (lsa001_._4) .irflag = 0;
    (lsa001_._4) .pdest = 0.;
    (lsa001_._4) .pdlast = 0.;
    (lsa001_._4) .ratio = 5.;
    cfode_(&c__2, (ls0001_._6) .elco, (ls0001_._6) .tesco);
    for (i__ = 1; i__ <= 5; ++i__) {
 
	(lsa001_._4) .cm2[i__ - 1] = (ls0001_._6) .tesco[i__ * 3 - 2] * (ls0001_._6) .elco[
		i__ + 1 + i__ * 13 - 14];
    }
    cfode_(&c__1, (ls0001_._6) .elco, (ls0001_._6) .tesco);
    for (i__ = 1; i__ <= 12; ++i__) {
 
	(lsa001_._4) .cm1[i__ - 1] = (ls0001_._6) .tesco[i__ * 3 - 2] * (ls0001_._6) .elco[
		i__ + 1 + i__ * 13 - 14];
    }
    goto L150;
 

 
 
 
 
 
 
 
 
 
 

L100:
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1;
    if ((ls0001_._6) .ialth == 1) {
	(ls0001_._6) .ialth = 2;
    }
    if ((ls0001_._6) .meth == (lsa001_._4) .mused) {
	goto L160;
    }
    cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco);
    (ls0001_._6) .ialth = (ls0001_._6) .l;
    iret = 1;
 

 
 
 

L150:
    i__1 = (ls0001_._6) .l;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14];
    }
    (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh;
    (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0;
    (ls0001_._6) .el0 = (ls0001_._6) .el[0];
    (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2);
    switch ((int)iret) {
	case 1:  goto L160;
	case 2:  goto L170;
	case 3:  goto L200;
    }
 

 
 
 
 
 

L160:
    if ((ls0001_._6) .h__ == (ls0001_._6) .hold) {
	goto L200;
    }
    rh = (ls0001_._6) .h__ / (ls0001_._6) .hold;
    (ls0001_._6) .h__ = (ls0001_._6) .hold;
    iredo = 3;
    goto L175;
L170:
 
    d__1 = rh, d__2 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
L175:
    rh = (( rh ) <= ( (ls0001_._6) .rmax ) ? ( rh ) : ( (ls0001_._6) .rmax )) ;
 
    d__1 = 1., d__2 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  * (ls0001_._6) .hmxi * rh;
    rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 

 

 
 
 

    if ((ls0001_._6) .meth == 2) {
	goto L178;
    }
    (lsa001_._4) .irflag = 0;
 
    d__1 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  * (lsa001_._4) .pdlast;
    pdh = (( d__1 ) >= ( 1e-6 ) ? ( d__1 ) : ( 1e-6 )) ;
    if (rh * pdh * 1.00001 < sm1[(ls0001_._6) .nq - 1]) {
	goto L178;
    }
    rh = sm1[(ls0001_._6) .nq - 1] / pdh;
    (lsa001_._4) .irflag = 1;
L178:
    r__ = 1.;
    i__1 = (ls0001_._6) .l;
    for (j = 2; j <= i__1; ++j) {
	r__ *= rh;
	i__2 = (ls0001_._6) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    yh[i__ + j * yh_dim1] *= r__;
	}
    }
    (ls0001_._6) .h__ *= rh;
    (ls0001_._6) .rc *= rh;
    (ls0001_._6) .ialth = (ls0001_._6) .l;
    if (iredo == 0) {
	goto L690;
    }
 

 
 
 
 
 
 
 

L200:
    if ((d__1 = (ls0001_._6) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._6) .ccmax) {
	(ls0001_._6) .ipup = (ls0001_._6) .miter;
    }
    if ((ls0001_._6) .nst >= (ls0001_._6) .nslp + (ls0001_._6) .msbp) {
	(ls0001_._6) .ipup = (ls0001_._6) .miter;
    }
    (ls0001_._6) .tn += (ls0001_._6) .h__;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__2 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] += yh1[i__ + *nyh];
	}
 
    }
    pnorm = vmnorm_(& (ls0001_._6) .n, &yh1[1], &ewt[1]);
 

 
 
 
 
 

L220:
    m = 0;
    rate = 0.;
    del = 0.;
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	y[i__] = yh[i__ + yh_dim1];
    }
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    if ((ls0001_._6) .ipup <= 0) {
	goto L250;
    }
 

 
 
 
 

    (ls0001_._6) .ipup = 0;
    (ls0001_._6) .rc = 1.;
    (ls0001_._6) .nslp = (ls0001_._6) .nst;
    (ls0001_._6) .crate = .7;
    (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savf[1], 
	    &wm[1], &iwm[1], f, jac);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if ((ls0001_._6) .ierpj != 0) {
	goto L430;
    }
L250:
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	acor[i__] = 0.;
    }
L270:
    if ((ls0001_._6) .miter != 0) {
	goto L350;
    }
 

 
 
 

    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	savf[i__] = (ls0001_._6) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)];
 
	y[i__] = savf[i__] - acor[i__];
    }
    del = vmnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]);
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * savf[i__];
 
	acor[i__] = savf[i__];
    }
    goto L400;
 

 
 
 
 

L350:
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	y[i__] = (ls0001_._6) .h__ * savf[i__] - (yh[i__ + (yh_dim1 << 1)] + acor[
		i__]);
    }
    (*slvs)(&wm[1], &iwm[1], &y[1], &savf[1]);
    if ((ls0001_._6) .iersl < 0) {
	goto L430;
    }
    if ((ls0001_._6) .iersl > 0) {
	goto L410;
    }
    del = vmnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]);
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	acor[i__] += y[i__];
 
	y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * acor[i__];
    }
 

 
 

 
 
 
 
 
 
 
 

L400:
    if (del <= pnorm * 100. * (ls0001_._6) .uround) {
	goto L450;
    }
    if (m == 0 && (ls0001_._6) .meth == 1) {
	goto L405;
    }
    if (m == 0) {
	goto L402;
    }
    rm = 1024.;
    if (del <= delp * 1024.) {
	rm = del / delp;
    }
    rate = (( rate ) >= ( rm ) ? ( rate ) : ( rm )) ;
 
    d__1 = (ls0001_._6) .crate * .2;
    (ls0001_._6) .crate = (( d__1 ) >= ( rm ) ? ( d__1 ) : ( rm )) ;
L402:
 
    d__1 = 1., d__2 = (ls0001_._6) .crate * 1.5;
    dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 ))  / ((ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2] * 
	    (ls0001_._6) .conit);
    if (dcon > 1.) {
	goto L405;
    }
 
    d__2 = (lsa001_._4) .pdest, d__3 = rate / (d__1 = (ls0001_._6) .h__ * (ls0001_._6) .el[0]
	    , (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    (lsa001_._4) .pdest = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    if ((lsa001_._4) .pdest != 0.) {
	(lsa001_._4) .pdlast = (lsa001_._4) .pdest;
    }
    goto L450;
L405:
    ++m;
    if (m == (ls0001_._6) .maxcor) {
	goto L410;
    }
    if (m >= 2 && del > delp * 2.) {
	goto L410;
    }
    delp = del;
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    goto L270;
 

 
 
 
 
 
 

L410:
    if ((ls0001_._6) .miter == 0 || (ls0001_._6) .jcur == 1) {
	goto L430;
    }
    (ls0001_._6) .icf = 1;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    goto L220;
L430:
    (ls0001_._6) .icf = 2;
    ++ncf;
    (ls0001_._6) .rmax = 2.;
    (ls0001_._6) .tn = told;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__2 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    if ((ls0001_._6) .ierpj < 0 || (ls0001_._6) .iersl < 0) {
	goto L680;
    }
    if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  <= (ls0001_._6) .hmin * 1.00001) {
	goto L670;
    }
    if (ncf == (ls0001_._6) .mxncf) {
	goto L670;
    }
    rh = .25;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    iredo = 1;
    goto L170;
 

 
 
 
 
 

L450:
    (ls0001_._6) .jcur = 0;
    if (m == 0) {
	dsm = del / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2];
    }
    if (m > 0) {
	dsm = vmnorm_(& (ls0001_._6) .n, &acor[1], &ewt[1]) / (ls0001_._6) .tesco[
		(ls0001_._6) .nq * 3 - 2];
    }
    if (dsm > 1.) {
	goto L500;
    }
 

 
 
 
 
 
 
 
 
 
 
 
 

    (ls0001_._6) .kflag = 0;
    iredo = 0;
    ++ (ls0001_._6) .nst;
    (ls0001_._6) .hu = (ls0001_._6) .h__;
    (ls0001_._6) .nqu = (ls0001_._6) .nq;
    (lsa001_._4) .mused = (ls0001_._6) .meth;
    i__2 = (ls0001_._6) .l;
    for (j = 1; j <= i__2; ++j) {
	i__1 = (ls0001_._6) .n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    yh[i__ + j * yh_dim1] += (ls0001_._6) .el[j - 1] * acor[i__];
	}
    }
    -- (lsa001_._4) .icount;
    if ((lsa001_._4) .icount >= 0) {
	goto L488;
    }
    if ((ls0001_._6) .meth == 2) {
	goto L480;
    }
 

 
 
 
 
 
 
 
 
 

 
 
 
 

 
 
 

    if ((ls0001_._6) .nq > 5) {
	goto L488;
    }
    if (dsm > pnorm * 100. * (ls0001_._6) .uround && (lsa001_._4) .pdest != 0.) {
	goto L470;
    }
    if ((lsa001_._4) .irflag == 0) {
	goto L488;
    }
    rh2 = 2.;
    nqm2 = (( (ls0001_._6) .nq ) <= ( (lsa001_._4) .mxords ) ? ( (ls0001_._6) .nq ) : ( (lsa001_._4) .mxords )) ;
    goto L478;
L470:
    exsm = 1. / (doublereal) (ls0001_._6) .l;
    rh1 = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6);
    rh1it = rh1 * 2.;
    pdh = (lsa001_._4) .pdlast * (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    if (pdh * rh1 > 1e-5) {
	rh1it = sm1[(ls0001_._6) .nq - 1] / pdh;
    }
    rh1 = (( rh1 ) <= ( rh1it ) ? ( rh1 ) : ( rh1it )) ;
    if ((ls0001_._6) .nq <= (lsa001_._4) .mxords) {
	goto L474;
    }
    nqm2 = (lsa001_._4) .mxords;
    lm2 = (lsa001_._4) .mxords + 1;
    exm2 = 1. / (doublereal) lm2;
    lm2p1 = lm2 + 1;
    dm2 = vmnorm_(& (ls0001_._6) .n, &yh[lm2p1 * yh_dim1 + 1], &ewt[1]) / 
	    (lsa001_._4) .cm2[(lsa001_._4) .mxords - 1];
    rh2 = 1. / (pow_dd(&dm2, &exm2) * 1.2 + 1.2e-6);
    goto L476;
L474:
    dm2 = dsm * ((lsa001_._4) .cm1[(ls0001_._6) .nq - 1] / (lsa001_._4) .cm2[(ls0001_._6) .nq - 1]
	    );
    rh2 = 1. / (pow_dd(&dm2, &exsm) * 1.2 + 1.2e-6);
    nqm2 = (ls0001_._6) .nq;
L476:
    if (rh2 < (lsa001_._4) .ratio * rh1) {
	goto L488;
    }
 

L478:
    rh = rh2;
    (lsa001_._4) .icount = 20;
    (ls0001_._6) .meth = 2;
    (ls0001_._6) .miter = (lsa001_._4) .jtyp;
    (lsa001_._4) .pdlast = 0.;
    (ls0001_._6) .nq = nqm2;
    (ls0001_._6) .l = (ls0001_._6) .nq + 1;
    goto L170;
 

 
 
 
 

 
 
 
 
 

L480:
    exsm = 1. / (doublereal) (ls0001_._6) .l;
    if ((lsa001_._4) .mxordn >= (ls0001_._6) .nq) {
	goto L484;
    }
    nqm1 = (lsa001_._4) .mxordn;
    lm1 = (lsa001_._4) .mxordn + 1;
    exm1 = 1. / (doublereal) lm1;
    lm1p1 = lm1 + 1;
    dm1 = vmnorm_(& (ls0001_._6) .n, &yh[lm1p1 * yh_dim1 + 1], &ewt[1]) / 
	    (lsa001_._4) .cm1[(lsa001_._4) .mxordn - 1];
    rh1 = 1. / (pow_dd(&dm1, &exm1) * 1.2 + 1.2e-6);
    goto L486;
L484:
    dm1 = dsm * ((lsa001_._4) .cm2[(ls0001_._6) .nq - 1] / (lsa001_._4) .cm1[(ls0001_._6) .nq - 1]
	    );
    rh1 = 1. / (pow_dd(&dm1, &exsm) * 1.2 + 1.2e-6);
    nqm1 = (ls0001_._6) .nq;
    exm1 = exsm;
L486:
    rh1it = rh1 * 2.;
    pdh = (lsa001_._4) .pdnorm * (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    if (pdh * rh1 > 1e-5) {
	rh1it = sm1[nqm1 - 1] / pdh;
    }
    rh1 = (( rh1 ) <= ( rh1it ) ? ( rh1 ) : ( rh1it )) ;
    rh2 = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6);
    if (rh1 * (lsa001_._4) .ratio < rh2 * 5.) {
	goto L488;
    }
    alpha = (( .001 ) >= ( rh1 ) ? ( .001 ) : ( rh1 )) ;
    dm1 = pow_dd(&alpha, &exm1) * dm1;
    if (dm1 <= (ls0001_._6) .uround * 1e3 * pnorm) {
	goto L488;
    }
 

    rh = rh1;
    (lsa001_._4) .icount = 20;
    (ls0001_._6) .meth = 1;
    (ls0001_._6) .miter = 0;
    (lsa001_._4) .pdlast = 0.;
    (ls0001_._6) .nq = nqm1;
    (ls0001_._6) .l = (ls0001_._6) .nq + 1;
    goto L170;

 

L488:
    -- (ls0001_._6) .ialth;
    if ((ls0001_._6) .ialth == 0) {
	goto L520;
    }
    if ((ls0001_._6) .ialth > 1) {
	goto L700;
    }
    if ((ls0001_._6) .l == (ls0001_._6) .lmax) {
	goto L700;
    }
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (ls0001_._6) .lmax * yh_dim1] = acor[i__];
    }
    goto L700;
 

 
 
 
 
 
 

L500:
    -- (ls0001_._6) .kflag;
    (ls0001_._6) .tn = told;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__1 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__1; ++jb) {
	i1 -= *nyh;
	i__2 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__2; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    (ls0001_._6) .rmax = 2.;
    if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  <= (ls0001_._6) .hmin * 1.00001) {
	goto L660;
    }
    if ((ls0001_._6) .kflag <= -3) {
	goto L640;
    }
    iredo = 2;
    rhup = 0.;
    goto L540;
 

 
 
 
 
 
 
 
 

L520:
    rhup = 0.;
    if ((ls0001_._6) .l == (ls0001_._6) .lmax) {
	goto L540;
    }
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	savf[i__] = acor[i__] - yh[i__ + (ls0001_._6) .lmax * yh_dim1];
    }
    dup = vmnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[
	    (ls0001_._6) .nq * 3 - 1];
    exup = 1. / (doublereal) ((ls0001_._6) .l + 1);
    rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6);
L540:
    exsm = 1. / (doublereal) (ls0001_._6) .l;
    rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6);
    rhdn = 0.;
    if ((ls0001_._6) .nq == 1) {
	goto L550;
    }
    ddn = vmnorm_(& (ls0001_._6) .n, &yh[(ls0001_._6) .l * yh_dim1 + 1], &ewt[1]) / 
	    (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 3];
    exdn = 1. / (doublereal) (ls0001_._6) .nq;
    rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6);
 

L550:
    if ((ls0001_._6) .meth == 2) {
	goto L560;
    }
 
    d__1 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  * (lsa001_._4) .pdlast;
    pdh = (( d__1 ) >= ( 1e-6 ) ? ( d__1 ) : ( 1e-6 )) ;
    if ((ls0001_._6) .l < (ls0001_._6) .lmax) {
 
	d__1 = rhup, d__2 = sm1[(ls0001_._6) .l - 1] / pdh;
	rhup = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
 
    d__1 = rhsm, d__2 = sm1[(ls0001_._6) .nq - 1] / pdh;
    rhsm = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    if ((ls0001_._6) .nq > 1) {
 
	d__1 = rhdn, d__2 = sm1[(ls0001_._6) .nq - 2] / pdh;
	rhdn = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    (lsa001_._4) .pdest = 0.;
L560:
    if (rhsm >= rhup) {
	goto L570;
    }
    if (rhup > rhdn) {
	goto L590;
    }
    goto L580;
L570:
    if (rhsm < rhdn) {
	goto L580;
    }
    newq = (ls0001_._6) .nq;
    rh = rhsm;
    goto L620;
L580:
    newq = (ls0001_._6) .nq - 1;
    rh = rhdn;
    if ((ls0001_._6) .kflag < 0 && rh > 1.) {
	rh = 1.;
    }
    goto L620;
L590:
    newq = (ls0001_._6) .l;
    rh = rhup;
    if (rh < 1.1) {
	goto L610;
    }
    r__ = (ls0001_._6) .el[(ls0001_._6) .l - 1] / (doublereal) (ls0001_._6) .l;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__;
    }
    goto L630;
L610:
    (ls0001_._6) .ialth = 3;
    goto L700;
 

L620:
    if ((ls0001_._6) .meth == 2) {
	goto L622;
    }
    if (rh * pdh * 1.00001 >= sm1[newq - 1]) {
	goto L625;
    }
L622:
    if ((ls0001_._6) .kflag == 0 && rh < 1.1) {
	goto L610;
    }
L625:
    if ((ls0001_._6) .kflag <= -2) {
	rh = (( rh ) <= ( .2 ) ? ( rh ) : ( .2 )) ;
    }
 

 
 
 
 

    if (newq == (ls0001_._6) .nq) {
	goto L170;
    }
L630:
    (ls0001_._6) .nq = newq;
    (ls0001_._6) .l = (ls0001_._6) .nq + 1;
    iret = 2;
    goto L150;
 

 
 
 
 
 
 
 
 

L640:
    if ((ls0001_._6) .kflag == -10) {
	goto L660;
    }
    rh = .1;
 
    d__1 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    rh = (( d__1 ) >= ( rh ) ? ( d__1 ) : ( rh )) ;
    (ls0001_._6) .h__ *= rh;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = yh[i__ + yh_dim1];
    }
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (yh_dim1 << 1)] = (ls0001_._6) .h__ * savf[i__];
    }
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    (ls0001_._6) .ialth = 5;
    if ((ls0001_._6) .nq == 1) {
	goto L200;
    }
    (ls0001_._6) .nq = 1;
    (ls0001_._6) .l = 2;
    iret = 3;
    goto L150;
 

 
 
 

L660:
    (ls0001_._6) .kflag = -1;
    goto L720;
L670:
    (ls0001_._6) .kflag = -2;
    goto L720;
L680:
    (ls0001_._6) .kflag = -3;
    goto L720;
L690:
    (ls0001_._6) .rmax = 10.;
L700:
    r__ = 1. / (ls0001_._6) .tesco[(ls0001_._6) .nqu * 3 - 2];
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	acor[i__] *= r__;
    }
L720:
    (ls0001_._6) .hold = (ls0001_._6) .h__;
    (ls0001_._6) .jstart = 1;
    return 0;
 

}  

 
  int stode_(neq, y, yh, nyh, yh1, ewt, savf, acor, wm, iwm, f,
	 jac, pjac, slvs)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *yh1, *ewt, *savf, *acor, *wm;
integer *iwm;
  int (*f) (), (*jac) (), (*pjac) (), (*slvs) ();
{
     
    integer yh_dim1, yh_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    double pow_dd();

     
    static doublereal dcon, delp, rhdn, exdn;
    static integer iret;
    static doublereal told, rhsm;
    static integer newq;
    static doublereal exsm, rhup, exup;
    static integer i__, j, m;
    extern   int cfode_();
    static doublereal r__;
    static integer iredo, i1;
    extern doublereal vnorm_();
    static integer jb;
    static doublereal rh, del, ddn;
    static integer ncf;
    static doublereal dsm, dup;

 
 

 
 
 
 
 

     
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --yh1;
    --ewt;
    --savf;
    --acor;
    --wm;
    --iwm;

     
    (ls0001_._6) .kflag = 0;
    told = (ls0001_._6) .tn;
    ncf = 0;
    (ls0001_._6) .ierpj = 0;
    (ls0001_._6) .iersl = 0;
    (ls0001_._6) .jcur = 0;
    (ls0001_._6) .icf = 0;
    if ((ls0001_._6) .jstart > 0) {
	goto L200;
    }
    if ((ls0001_._6) .jstart == -1) {
	goto L100;
    }
    if ((ls0001_._6) .jstart == -2) {
	goto L160;
    }
 

 
 
 
 
 
 
 

    (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1;
    (ls0001_._6) .nq = 1;
    (ls0001_._6) .l = 2;
    (ls0001_._6) .ialth = 2;
    (ls0001_._6) .rmax = 1e4;
    (ls0001_._6) .rc = 0.;
    (ls0001_._6) .el0 = 1.;
    (ls0001_._6) .crate = .7;
    delp = 0.;
    (ls0001_._6) .hold = (ls0001_._6) .h__;
    (ls0001_._6) .meo = (ls0001_._6) .meth;
    (ls0001_._6) .nslp = 0;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    iret = 3;
    goto L140;
 

 
 
 
 
 
 
 
 
 
 
 
 

L100:
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    (ls0001_._6) .lmax = (ls0001_._6) .maxord + 1;
    if ((ls0001_._6) .ialth == 1) {
	(ls0001_._6) .ialth = 2;
    }
    if ((ls0001_._6) .meth == (ls0001_._6) .meo) {
	goto L110;
    }
    cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco);
    (ls0001_._6) .meo = (ls0001_._6) .meth;
    if ((ls0001_._6) .nq > (ls0001_._6) .maxord) {
	goto L120;
    }
    (ls0001_._6) .ialth = (ls0001_._6) .l;
    iret = 1;
    goto L150;
L110:
    if ((ls0001_._6) .nq <= (ls0001_._6) .maxord) {
	goto L160;
    }
L120:
    (ls0001_._6) .nq = (ls0001_._6) .maxord;
    (ls0001_._6) .l = (ls0001_._6) .lmax;
    i__1 = (ls0001_._6) .l;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14];
    }
    (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh;
    (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0;
    (ls0001_._6) .el0 = (ls0001_._6) .el[0];
    (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2);
    ddn = vnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .l *
	     3 - 3];
    exdn = 1. / (doublereal) (ls0001_._6) .l;
    rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6);
    rh = (( rhdn ) <= ( 1. ) ? ( rhdn ) : ( 1. )) ;
    iredo = 3;
    if ((ls0001_._6) .h__ == (ls0001_._6) .hold) {
	goto L170;
    }
 
    d__2 = rh, d__3 = (d__1 = (ls0001_._6) .h__ / (ls0001_._6) .hold, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    rh = (( d__2 ) <= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    (ls0001_._6) .h__ = (ls0001_._6) .hold;
    goto L175;
 

 
 
 
 

L140:
    cfode_(& (ls0001_._6) .meth, (ls0001_._6) .elco, (ls0001_._6) .tesco);
L150:
    i__1 = (ls0001_._6) .l;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._6) .el[i__ - 1] = (ls0001_._6) .elco[i__ + (ls0001_._6) .nq * 13 - 14];
    }
    (ls0001_._6) .nqnyh = (ls0001_._6) .nq * *nyh;
    (ls0001_._6) .rc = (ls0001_._6) .rc * (ls0001_._6) .el[0] / (ls0001_._6) .el0;
    (ls0001_._6) .el0 = (ls0001_._6) .el[0];
    (ls0001_._6) .conit = .5 / (doublereal) ((ls0001_._6) .nq + 2);
    switch ((int)iret) {
	case 1:  goto L160;
	case 2:  goto L170;
	case 3:  goto L200;
    }
 

 
 
 
 
 

L160:
    if ((ls0001_._6) .h__ == (ls0001_._6) .hold) {
	goto L200;
    }
    rh = (ls0001_._6) .h__ / (ls0001_._6) .hold;
    (ls0001_._6) .h__ = (ls0001_._6) .hold;
    iredo = 3;
    goto L175;
L170:
 
    d__1 = rh, d__2 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
L175:
    rh = (( rh ) <= ( (ls0001_._6) .rmax ) ? ( rh ) : ( (ls0001_._6) .rmax )) ;
 
    d__1 = 1., d__2 = (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  * (ls0001_._6) .hmxi * rh;
    rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    r__ = 1.;
    i__1 = (ls0001_._6) .l;
    for (j = 2; j <= i__1; ++j) {
	r__ *= rh;
	i__2 = (ls0001_._6) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    yh[i__ + j * yh_dim1] *= r__;
	}
    }
    (ls0001_._6) .h__ *= rh;
    (ls0001_._6) .rc *= rh;
    (ls0001_._6) .ialth = (ls0001_._6) .l;
    if (iredo == 0) {
	goto L690;
    }
 

 
 
 
 
 
 
 

L200:
    if ((d__1 = (ls0001_._6) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._6) .ccmax) {
	(ls0001_._6) .ipup = (ls0001_._6) .miter;
    }
    if ((ls0001_._6) .nst >= (ls0001_._6) .nslp + (ls0001_._6) .msbp) {
	(ls0001_._6) .ipup = (ls0001_._6) .miter;
    }
    (ls0001_._6) .tn += (ls0001_._6) .h__;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__2 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] += yh1[i__ + *nyh];
	}
 
    }
 

 
 
 
 
 

L220:
    m = 0;
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	y[i__] = yh[i__ + yh_dim1];
    }
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    if ((ls0001_._6) .ipup <= 0) {
	goto L250;
    }
 

 
 
 
 

    (ls0001_._6) .ipup = 0;
    (ls0001_._6) .rc = 1.;
    (ls0001_._6) .nslp = (ls0001_._6) .nst;
    (ls0001_._6) .crate = .7;
    (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savf[1], 
	    &wm[1], &iwm[1], f, jac);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if ((ls0001_._6) .ierpj != 0) {
	goto L430;
    }
L250:
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	acor[i__] = 0.;
    }
L270:
    if ((ls0001_._6) .miter != 0) {
	goto L350;
    }
 

 
 
 

    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	savf[i__] = (ls0001_._6) .h__ * savf[i__] - yh[i__ + (yh_dim1 << 1)];
 
	y[i__] = savf[i__] - acor[i__];
    }
    del = vnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]);
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * savf[i__];
 
	acor[i__] = savf[i__];
    }
    goto L400;
 

 
 
 
 

L350:
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	y[i__] = (ls0001_._6) .h__ * savf[i__] - (yh[i__ + (yh_dim1 << 1)] + acor[
		i__]);
    }
    (*slvs)(&wm[1], &iwm[1], &y[1], &savf[1]);
    if ((ls0001_._6) .iersl < 0) {
	goto L430;
    }
    if ((ls0001_._6) .iersl > 0) {
	goto L410;
    }
    del = vnorm_(& (ls0001_._6) .n, &y[1], &ewt[1]);
    i__2 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	acor[i__] += y[i__];
 
	y[i__] = yh[i__ + yh_dim1] + (ls0001_._6) .el[0] * acor[i__];
    }
 

 
 
 

L400:
    if (m != 0) {
 
	d__1 = (ls0001_._6) .crate * .2, d__2 = del / delp;
	(ls0001_._6) .crate = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
 
    d__1 = 1., d__2 = (ls0001_._6) .crate * 1.5;
    dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 ))  / ((ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2] * 
	    (ls0001_._6) .conit);
    if (dcon <= 1.) {
	goto L450;
    }
    ++m;
    if (m == (ls0001_._6) .maxcor) {
	goto L410;
    }
    if (m >= 2 && del > delp * 2.) {
	goto L410;
    }
    delp = del;
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    goto L270;
 

 
 
 
 
 
 

L410:
    if ((ls0001_._6) .miter == 0 || (ls0001_._6) .jcur == 1) {
	goto L430;
    }
    (ls0001_._6) .icf = 1;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    goto L220;
L430:
    (ls0001_._6) .icf = 2;
    ++ncf;
    (ls0001_._6) .rmax = 2.;
    (ls0001_._6) .tn = told;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__2 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    if ((ls0001_._6) .ierpj < 0 || (ls0001_._6) .iersl < 0) {
	goto L680;
    }
    if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  <= (ls0001_._6) .hmin * 1.00001) {
	goto L670;
    }
    if (ncf == (ls0001_._6) .mxncf) {
	goto L670;
    }
    rh = .25;
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    iredo = 1;
    goto L170;
 

 
 
 
 
 

L450:
    (ls0001_._6) .jcur = 0;
    if (m == 0) {
	dsm = del / (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 2];
    }
    if (m > 0) {
	dsm = vnorm_(& (ls0001_._6) .n, &acor[1], &ewt[1]) / (ls0001_._6) .tesco[
		(ls0001_._6) .nq * 3 - 2];
    }
    if (dsm > 1.) {
	goto L500;
    }
 

 
 
 
 
 
 
 
 
 

    (ls0001_._6) .kflag = 0;
    iredo = 0;
    ++ (ls0001_._6) .nst;
    (ls0001_._6) .hu = (ls0001_._6) .h__;
    (ls0001_._6) .nqu = (ls0001_._6) .nq;
    i__2 = (ls0001_._6) .l;
    for (j = 1; j <= i__2; ++j) {
	i__1 = (ls0001_._6) .n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    yh[i__ + j * yh_dim1] += (ls0001_._6) .el[j - 1] * acor[i__];
	}
    }
    -- (ls0001_._6) .ialth;
    if ((ls0001_._6) .ialth == 0) {
	goto L520;
    }
    if ((ls0001_._6) .ialth > 1) {
	goto L700;
    }
    if ((ls0001_._6) .l == (ls0001_._6) .lmax) {
	goto L700;
    }
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (ls0001_._6) .lmax * yh_dim1] = acor[i__];
    }
    goto L700;
 

 
 
 
 
 
 

L500:
    -- (ls0001_._6) .kflag;
    (ls0001_._6) .tn = told;
    i1 = (ls0001_._6) .nqnyh + 1;
    i__1 = (ls0001_._6) .nq;
    for (jb = 1; jb <= i__1; ++jb) {
	i1 -= *nyh;
	i__2 = (ls0001_._6) .nqnyh;
	for (i__ = i1; i__ <= i__2; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    (ls0001_._6) .rmax = 2.;
    if ((( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ ))  <= (ls0001_._6) .hmin * 1.00001) {
	goto L660;
    }
    if ((ls0001_._6) .kflag <= -3) {
	goto L640;
    }
    iredo = 2;
    rhup = 0.;
    goto L540;
 

 
 
 
 
 
 
 
 

L520:
    rhup = 0.;
    if ((ls0001_._6) .l == (ls0001_._6) .lmax) {
	goto L540;
    }
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	savf[i__] = acor[i__] - yh[i__ + (ls0001_._6) .lmax * yh_dim1];
    }
    dup = vnorm_(& (ls0001_._6) .n, &savf[1], &ewt[1]) / (ls0001_._6) .tesco[(ls0001_._6) .nq 
	    * 3 - 1];
    exup = 1. / (doublereal) ((ls0001_._6) .l + 1);
    rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6);
L540:
    exsm = 1. / (doublereal) (ls0001_._6) .l;
    rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6);
    rhdn = 0.;
    if ((ls0001_._6) .nq == 1) {
	goto L560;
    }
    ddn = vnorm_(& (ls0001_._6) .n, &yh[(ls0001_._6) .l * yh_dim1 + 1], &ewt[1]) / 
	    (ls0001_._6) .tesco[(ls0001_._6) .nq * 3 - 3];
    exdn = 1. / (doublereal) (ls0001_._6) .nq;
    rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6);
L560:
    if (rhsm >= rhup) {
	goto L570;
    }
    if (rhup > rhdn) {
	goto L590;
    }
    goto L580;
L570:
    if (rhsm < rhdn) {
	goto L580;
    }
    newq = (ls0001_._6) .nq;
    rh = rhsm;
    goto L620;
L580:
    newq = (ls0001_._6) .nq - 1;
    rh = rhdn;
    if ((ls0001_._6) .kflag < 0 && rh > 1.) {
	rh = 1.;
    }
    goto L620;
L590:
    newq = (ls0001_._6) .l;
    rh = rhup;
    if (rh < 1.1) {
	goto L610;
    }
    r__ = (ls0001_._6) .el[(ls0001_._6) .l - 1] / (doublereal) (ls0001_._6) .l;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__;
    }
    goto L630;
L610:
    (ls0001_._6) .ialth = 3;
    goto L700;
L620:
    if ((ls0001_._6) .kflag == 0 && rh < 1.1) {
	goto L610;
    }
    if ((ls0001_._6) .kflag <= -2) {
	rh = (( rh ) <= ( .2 ) ? ( rh ) : ( .2 )) ;
    }
 

 
 
 
 

    if (newq == (ls0001_._6) .nq) {
	goto L170;
    }
L630:
    (ls0001_._6) .nq = newq;
    (ls0001_._6) .l = (ls0001_._6) .nq + 1;
    iret = 2;
    goto L150;
 

 
 
 
 
 
 
 
 

L640:
    if ((ls0001_._6) .kflag == -10) {
	goto L660;
    }
    rh = .1;
 
    d__1 = (ls0001_._6) .hmin / (( (ls0001_._6) .h__ ) >= 0 ? ( (ls0001_._6) .h__ ) : -( (ls0001_._6) .h__ )) ;
    rh = (( d__1 ) >= ( rh ) ? ( d__1 ) : ( rh )) ;
    (ls0001_._6) .h__ *= rh;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[i__] = yh[i__ + yh_dim1];
    }
    (*f)(&neq[1], & (ls0001_._6) .tn, &y[1], &savf[1]);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._6) .nfe;
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (yh_dim1 << 1)] = (ls0001_._6) .h__ * savf[i__];
    }
    (ls0001_._6) .ipup = (ls0001_._6) .miter;
    (ls0001_._6) .ialth = 5;
    if ((ls0001_._6) .nq == 1) {
	goto L200;
    }
    (ls0001_._6) .nq = 1;
    (ls0001_._6) .l = 2;
    iret = 3;
    goto L150;
 

 
 
 

L660:
    (ls0001_._6) .kflag = -1;
    goto L720;
L670:
    (ls0001_._6) .kflag = -2;
    goto L720;
L680:
    (ls0001_._6) .kflag = -3;
    goto L720;
L690:
    (ls0001_._6) .rmax = 10.;
L700:
    r__ = 1. / (ls0001_._6) .tesco[(ls0001_._6) .nqu * 3 - 2];
    i__1 = (ls0001_._6) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	acor[i__] *= r__;
    }
L720:
    (ls0001_._6) .hold = (ls0001_._6) .h__;
    (ls0001_._6) .jstart = 1;
    return 0;
 

}  

 
  int stodi_(neq, y, yh, nyh, yh1, ewt, savf, savr, acor, wm, 
	iwm, res, adda, jac, pjac, slvs)
integer *neq;
doublereal *y, *yh;
integer *nyh;
doublereal *yh1, *ewt, *savf, *savr, *acor, *wm;
integer *iwm;
  int (*res) (), (*adda) (), (*jac) (), (*pjac) (), (*slvs) ();
{
     
    integer yh_dim1, yh_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    double pow_dd();

     
    static doublereal dcon, delp, eljh, rhdn, exdn;
    static integer ires, iret;
    static doublereal told, rhsm;
    static integer newq;
    static doublereal exsm, rhup, exup;
    static integer i__, j, m;
    extern   int cfode_();
    static doublereal r__;
    static integer iredo, i1;
    extern doublereal vnorm_();
    static integer jb;
    static doublereal rh, del, ddn;
    static integer ncf, kgo;
    static doublereal dsm, dup, el1h;

 
 

 
 
 
 
 
 
 
 
 

     
    --neq;
    --y;
    yh_dim1 = *nyh;
    yh_offset = yh_dim1 + 1;
    yh -= yh_offset;
    --yh1;
    --ewt;
    --savf;
    --savr;
    --acor;
    --wm;
    --iwm;

     
    (ls0001_._7) .kflag = 0;
    told = (ls0001_._7) .tn;
    ncf = 0;
    (ls0001_._7) .ierpj = 0;
    (ls0001_._7) .iersl = 0;
    (ls0001_._7) .jcur = 0;
    (ls0001_._7) .icf = 0;
    delp = 0.;
    if ((ls0001_._7) .jstart > 0) {
	goto L200;
    }
    if ((ls0001_._7) .jstart == -1) {
	goto L100;
    }
    if ((ls0001_._7) .jstart == -2) {
	goto L160;
    }
 

 
 
 
 
 
 
 

    (ls0001_._7) .lmax = (ls0001_._7) .maxord + 1;
    (ls0001_._7) .nq = 1;
    (ls0001_._7) .l = 2;
    (ls0001_._7) .ialth = 2;
    (ls0001_._7) .rmax = 1e4;
    (ls0001_._7) .rc = 0.;
    (ls0001_._7) .el0 = 1.;
    (ls0001_._7) .crate = .7;
    (ls0001_._7) .hold = (ls0001_._7) .h__;
    (ls0001_._7) .meo = (ls0001_._7) .meth;
    (ls0001_._7) .nslp = 0;
    (ls0001_._7) .ipup = (ls0001_._7) .miter;
    iret = 3;
    goto L140;
 

 
 
 
 
 
 
 
 
 
 
 
 

L100:
    (ls0001_._7) .ipup = (ls0001_._7) .miter;
    (ls0001_._7) .lmax = (ls0001_._7) .maxord + 1;
    if ((ls0001_._7) .ialth == 1) {
	(ls0001_._7) .ialth = 2;
    }
    if ((ls0001_._7) .meth == (ls0001_._7) .meo) {
	goto L110;
    }
    cfode_(& (ls0001_._7) .meth, (ls0001_._7) .elco, (ls0001_._7) .tesco);
    (ls0001_._7) .meo = (ls0001_._7) .meth;
    if ((ls0001_._7) .nq > (ls0001_._7) .maxord) {
	goto L120;
    }
    (ls0001_._7) .ialth = (ls0001_._7) .l;
    iret = 1;
    goto L150;
L110:
    if ((ls0001_._7) .nq <= (ls0001_._7) .maxord) {
	goto L160;
    }
L120:
    (ls0001_._7) .nq = (ls0001_._7) .maxord;
    (ls0001_._7) .l = (ls0001_._7) .lmax;
    i__1 = (ls0001_._7) .l;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._7) .el[i__ - 1] = (ls0001_._7) .elco[i__ + (ls0001_._7) .nq * 13 - 14];
    }
    (ls0001_._7) .nqnyh = (ls0001_._7) .nq * *nyh;
    (ls0001_._7) .rc = (ls0001_._7) .rc * (ls0001_._7) .el[0] / (ls0001_._7) .el0;
    (ls0001_._7) .el0 = (ls0001_._7) .el[0];
    (ls0001_._7) .conit = .5 / (doublereal) ((ls0001_._7) .nq + 2);
    ddn = vnorm_(& (ls0001_._7) .n, &savf[1], &ewt[1]) / (ls0001_._7) .tesco[(ls0001_._7) .l *
	     3 - 3];
    exdn = 1. / (doublereal) (ls0001_._7) .l;
    rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6);
    rh = (( rhdn ) <= ( 1. ) ? ( rhdn ) : ( 1. )) ;
    iredo = 3;
    if ((ls0001_._7) .h__ == (ls0001_._7) .hold) {
	goto L170;
    }
 
    d__2 = rh, d__3 = (d__1 = (ls0001_._7) .h__ / (ls0001_._7) .hold, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    rh = (( d__2 ) <= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    (ls0001_._7) .h__ = (ls0001_._7) .hold;
    goto L175;
 

 
 
 
 

L140:
    cfode_(& (ls0001_._7) .meth, (ls0001_._7) .elco, (ls0001_._7) .tesco);
L150:
    i__1 = (ls0001_._7) .l;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	(ls0001_._7) .el[i__ - 1] = (ls0001_._7) .elco[i__ + (ls0001_._7) .nq * 13 - 14];
    }
    (ls0001_._7) .nqnyh = (ls0001_._7) .nq * *nyh;
    (ls0001_._7) .rc = (ls0001_._7) .rc * (ls0001_._7) .el[0] / (ls0001_._7) .el0;
    (ls0001_._7) .el0 = (ls0001_._7) .el[0];
    (ls0001_._7) .conit = .5 / (doublereal) ((ls0001_._7) .nq + 2);
    switch ((int)iret) {
	case 1:  goto L160;
	case 2:  goto L170;
	case 3:  goto L200;
    }
 

 
 
 
 
 

L160:
    if ((ls0001_._7) .h__ == (ls0001_._7) .hold) {
	goto L200;
    }
    rh = (ls0001_._7) .h__ / (ls0001_._7) .hold;
    (ls0001_._7) .h__ = (ls0001_._7) .hold;
    iredo = 3;
    goto L175;
L170:
 
    d__1 = rh, d__2 = (ls0001_._7) .hmin / (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) ;
    rh = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
L175:
    rh = (( rh ) <= ( (ls0001_._7) .rmax ) ? ( rh ) : ( (ls0001_._7) .rmax )) ;
 
    d__1 = 1., d__2 = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ ))  * (ls0001_._7) .hmxi * rh;
    rh /= (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    r__ = 1.;
    i__1 = (ls0001_._7) .l;
    for (j = 2; j <= i__1; ++j) {
	r__ *= rh;
	i__2 = (ls0001_._7) .n;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    yh[i__ + j * yh_dim1] *= r__;
	}
    }
    (ls0001_._7) .h__ *= rh;
    (ls0001_._7) .rc *= rh;
    (ls0001_._7) .ialth = (ls0001_._7) .l;
    if (iredo == 0) {
	goto L690;
    }
 

 
 
 
 
 
 
 

L200:
    if ((d__1 = (ls0001_._7) .rc - 1., (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > (ls0001_._7) .ccmax) {
	(ls0001_._7) .ipup = (ls0001_._7) .miter;
    }
    if ((ls0001_._7) .nst >= (ls0001_._7) .nslp + (ls0001_._7) .msbp) {
	(ls0001_._7) .ipup = (ls0001_._7) .miter;
    }
    (ls0001_._7) .tn += (ls0001_._7) .h__;
    i1 = (ls0001_._7) .nqnyh + 1;
    i__2 = (ls0001_._7) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._7) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] += yh1[i__ + *nyh];
	}
 
    }
 

 
 
 
 
 

L220:
    m = 0;
    i__2 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	savf[i__] = yh[i__ + (yh_dim1 << 1)] / (ls0001_._7) .h__;
 
	y[i__] = yh[i__ + yh_dim1];
    }
    if ((ls0001_._7) .ipup <= 0) {
	goto L240;
    }
 

 
 
 
 

    (ls0001_._7) .ipup = 0;
    (ls0001_._7) .rc = 1.;
    (ls0001_._7) .nslp = (ls0001_._7) .nst;
    (ls0001_._7) .crate = .7;
    (*pjac)(&neq[1], &y[1], &yh[yh_offset], nyh, &ewt[1], &acor[1], &savr[1], 
	    &savf[1], &wm[1], &iwm[1], res, jac, adda);
    if (ierode_ .iero > 0) {
	return 0;
    }
    if ((ls0001_._7) .ierpj == 0) {
	goto L250;
    }
    ires = (ls0001_._7) .ierpj;
    switch ((int)ires) {
	case 1:  goto L430;
	case 2:  goto L435;
	case 3:  goto L430;
    }
 

L240:
    ires = 1;
    (*res)(&neq[1], & (ls0001_._7) .tn, &y[1], &savf[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._7) .nre;
    kgo = (( ires ) >= 0 ? ( ires ) : -( ires )) ;
    switch ((int)kgo) {
	case 1:  goto L250;
	case 2:  goto L435;
	case 3:  goto L430;
    }
L250:
    i__2 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
 
	acor[i__] = 0.;
    }
 

 
 
 

L270:
    (*slvs)(&wm[1], &iwm[1], &savr[1], &savf[1]);
    if ((ls0001_._7) .iersl < 0) {
	goto L430;
    }
    if ((ls0001_._7) .iersl > 0) {
	goto L410;
    }
    el1h = (ls0001_._7) .el[0] * (ls0001_._7) .h__;
    del = vnorm_(& (ls0001_._7) .n, &savr[1], &ewt[1]) * (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ )) ;
    i__2 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__2; ++i__) {
	acor[i__] += savr[i__];
	savf[i__] = acor[i__] + yh[i__ + (yh_dim1 << 1)] / (ls0001_._7) .h__;
 
	y[i__] = yh[i__ + yh_dim1] + el1h * acor[i__];
    }
 

 
 
 

    if (m != 0) {
 
	d__1 = (ls0001_._7) .crate * .2, d__2 = del / delp;
	(ls0001_._7) .crate = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
 
    d__1 = 1., d__2 = (ls0001_._7) .crate * 1.5;
    dcon = del * (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 ))  / ((ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2] * 
	    (ls0001_._7) .conit);
    if (dcon <= 1.) {
	goto L460;
    }
    ++m;
    if (m == (ls0001_._7) .maxcor) {
	goto L410;
    }
    if (m >= 2 && del > delp * 2.) {
	goto L410;
    }
    delp = del;
    ires = 1;
    (*res)(&neq[1], & (ls0001_._7) .tn, &y[1], &savf[1], &savr[1], &ires);
    if (ierode_ .iero > 0) {
	return 0;
    }
    ++ (ls0001_._7) .nre;
    kgo = (( ires ) >= 0 ? ( ires ) : -( ires )) ;
    switch ((int)kgo) {
	case 1:  goto L270;
	case 2:  goto L435;
	case 3:  goto L410;
    }
 

 
 
 
 
 
 
 

L410:
    (ls0001_._7) .icf = 1;
    if ((ls0001_._7) .jcur == 1) {
	goto L430;
    }
    (ls0001_._7) .ipup = (ls0001_._7) .miter;
    goto L220;
L430:
    (ls0001_._7) .icf = 2;
    ++ncf;
    (ls0001_._7) .rmax = 2.;
L435:
    (ls0001_._7) .tn = told;
    i1 = (ls0001_._7) .nqnyh + 1;
    i__2 = (ls0001_._7) .nq;
    for (jb = 1; jb <= i__2; ++jb) {
	i1 -= *nyh;
	i__1 = (ls0001_._7) .nqnyh;
	for (i__ = i1; i__ <= i__1; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    if (ires == 2) {
	goto L680;
    }
    if ((ls0001_._7) .ierpj < 0 || (ls0001_._7) .iersl < 0) {
	goto L685;
    }
    if ((( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ ))  <= (ls0001_._7) .hmin * 1.00001) {
	goto L450;
    }
    if (ncf == (ls0001_._7) .mxncf) {
	goto L450;
    }
    rh = .25;
    (ls0001_._7) .ipup = (ls0001_._7) .miter;
    iredo = 1;
    goto L170;
L450:
    if (ires == 3) {
	goto L680;
    }
    goto L670;
 

 
 
 
 
 

L460:
    (ls0001_._7) .jcur = 0;
    if (m == 0) {
	dsm = del / (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2];
    }
    if (m > 0) {
	dsm = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ ))  * vnorm_(& (ls0001_._7) .n, &acor[1], &ewt[1]) / 
		(ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 2];
    }
    if (dsm > 1.) {
	goto L500;
    }
 

 
 
 
 
 
 
 
 
 

    (ls0001_._7) .kflag = 0;
    iredo = 0;
    ++ (ls0001_._7) .nst;
    (ls0001_._7) .hu = (ls0001_._7) .h__;
    (ls0001_._7) .nqu = (ls0001_._7) .nq;
    i__2 = (ls0001_._7) .l;
    for (j = 1; j <= i__2; ++j) {
	eljh = (ls0001_._7) .el[j - 1] * (ls0001_._7) .h__;
	i__1 = (ls0001_._7) .n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    yh[i__ + j * yh_dim1] += eljh * acor[i__];
	}
    }
    -- (ls0001_._7) .ialth;
    if ((ls0001_._7) .ialth == 0) {
	goto L520;
    }
    if ((ls0001_._7) .ialth > 1) {
	goto L700;
    }
    if ((ls0001_._7) .l == (ls0001_._7) .lmax) {
	goto L700;
    }
    i__1 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (ls0001_._7) .lmax * yh_dim1] = acor[i__];
    }
    goto L700;
 

 
 
 
 
 
 

L500:
    -- (ls0001_._7) .kflag;
    (ls0001_._7) .tn = told;
    i1 = (ls0001_._7) .nqnyh + 1;
    i__1 = (ls0001_._7) .nq;
    for (jb = 1; jb <= i__1; ++jb) {
	i1 -= *nyh;
	i__2 = (ls0001_._7) .nqnyh;
	for (i__ = i1; i__ <= i__2; ++i__) {
 
	    yh1[i__] -= yh1[i__ + *nyh];
	}
 
    }
    (ls0001_._7) .rmax = 2.;
    if ((( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ ))  <= (ls0001_._7) .hmin * 1.00001) {
	goto L660;
    }
    if ((ls0001_._7) .kflag <= -7) {
	goto L660;
    }
    iredo = 2;
    rhup = 0.;
    goto L540;
 

 
 
 
 
 
 
 
 

L520:
    rhup = 0.;
    if ((ls0001_._7) .l == (ls0001_._7) .lmax) {
	goto L540;
    }
    i__1 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	savf[i__] = acor[i__] - yh[i__ + (ls0001_._7) .lmax * yh_dim1];
    }
    dup = (( (ls0001_._7) .h__ ) >= 0 ? ( (ls0001_._7) .h__ ) : -( (ls0001_._7) .h__ ))  * vnorm_(& (ls0001_._7) .n, &savf[1], &ewt[1]) / 
	    (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 1];
    exup = 1. / (doublereal) ((ls0001_._7) .l + 1);
    rhup = 1. / (pow_dd(&dup, &exup) * 1.4 + 1.4e-6);
L540:
    exsm = 1. / (doublereal) (ls0001_._7) .l;
    rhsm = 1. / (pow_dd(&dsm, &exsm) * 1.2 + 1.2e-6);
    rhdn = 0.;
    if ((ls0001_._7) .nq == 1) {
	goto L560;
    }
    ddn = vnorm_(& (ls0001_._7) .n, &yh[(ls0001_._7) .l * yh_dim1 + 1], &ewt[1]) / 
	    (ls0001_._7) .tesco[(ls0001_._7) .nq * 3 - 3];
    exdn = 1. / (doublereal) (ls0001_._7) .nq;
    rhdn = 1. / (pow_dd(&ddn, &exdn) * 1.3 + 1.3e-6);
L560:
    if (rhsm >= rhup) {
	goto L570;
    }
    if (rhup > rhdn) {
	goto L590;
    }
    goto L580;
L570:
    if (rhsm < rhdn) {
	goto L580;
    }
    newq = (ls0001_._7) .nq;
    rh = rhsm;
    goto L620;
L580:
    newq = (ls0001_._7) .nq - 1;
    rh = rhdn;
    if ((ls0001_._7) .kflag < 0 && rh > 1.) {
	rh = 1.;
    }
    goto L620;
L590:
    newq = (ls0001_._7) .l;
    rh = rhup;
    if (rh < 1.1) {
	goto L610;
    }
    r__ = (ls0001_._7) .h__ * (ls0001_._7) .el[(ls0001_._7) .l - 1] / (doublereal) 
	    (ls0001_._7) .l;
    i__1 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	yh[i__ + (newq + 1) * yh_dim1] = acor[i__] * r__;
    }
    goto L630;
L610:
    (ls0001_._7) .ialth = 3;
    goto L700;
L620:
    if ((ls0001_._7) .kflag == 0 && rh < 1.1) {
	goto L610;
    }
    if ((ls0001_._7) .kflag <= -2) {
	rh = (( rh ) <= ( .1 ) ? ( rh ) : ( .1 )) ;
    }
 

 
 
 
 

    if (newq == (ls0001_._7) .nq) {
	goto L170;
    }
L630:
    (ls0001_._7) .nq = newq;
    (ls0001_._7) .l = (ls0001_._7) .nq + 1;
    iret = 2;
    goto L150;
 

 
 
 

L660:
    (ls0001_._7) .kflag = -1;
    goto L720;
L670:
    (ls0001_._7) .kflag = -2;
    goto L720;
L680:
    (ls0001_._7) .kflag = -1 - ires;
    goto L720;
L685:
    (ls0001_._7) .kflag = -5;
    goto L720;
L690:
    (ls0001_._7) .rmax = 10.;
L700:
    r__ = (ls0001_._7) .h__ / (ls0001_._7) .tesco[(ls0001_._7) .nqu * 3 - 2];
    i__1 = (ls0001_._7) .n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	acor[i__] *= r__;
    }
L720:
    (ls0001_._7) .hold = (ls0001_._7) .h__;
    (ls0001_._7) .jstart = 1;
    return 0;
 

}  

 
  int svcar1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;
    static integer lenrla = 22;
    static integer lenila = 9;
    static integer lenrlr = 5;
    static integer lenilr = 9;

     
    integer i__1;

     
    static integer i__, l;
    extern   int dcopy_();

 
 
 
 

 
 
     
    --isav;
    --rsav;

     

    l = 1;
    dcopy_(&lenrls, (ls0001_._5) .rls, &c__1, &rsav[l], &c__1);
    l += lenrls;
    dcopy_(&lenrla, (lsa001_._3) .rlsa, &c__1, &rsav[l], &c__1);
    l += lenrla;
    dcopy_(&lenrlr, (lsr001_._4) .rlsr, &c__1, &rsav[l], &c__1);

    l = 0;
    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
	isav[l + i__] = (doublereal) (ls0001_._5) .ils[i__ - 1];
 
    }
    l += lenils;
    i__1 = lenila;
    for (i__ = 1; i__ <= i__1; ++i__) {
	isav[l + i__] = (doublereal) (lsa001_._3) .ilsa[i__ - 1];
 
    }
    l += lenila;
    i__1 = lenilr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	isav[l + i__] = (doublereal) (lsr001_._4) .ilsr[i__ - 1];
 
    }
    l += lenilr;

    isav[l + 1] = (doublereal) (eh0001_._1) .ieh[0];
    isav[l + 2] = (doublereal) (eh0001_._1) .ieh[1];
    return 0;
}  

 
  int svcma1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;
    static integer lenrla = 22;
    static integer lenila = 9;

     
    integer i__1;

     
    static integer i__;

 
 
 
 

 
 
 
 
     
    --isav;
    --rsav;

     

    i__1 = lenrls;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rsav[i__] = (ls0001_._5) .rls[i__ - 1];
    }
    i__1 = lenrla;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rsav[lenrls + i__] = (lsa001_._3) .rlsa[i__ - 1];
    }

    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	isav[i__] = (doublereal) (ls0001_._5) .ils[i__ - 1];
    }
    i__1 = lenila;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	isav[lenils + i__] = (doublereal) (lsa001_._3) .ilsa[i__ - 1];
    }

    isav[lenils + lenila + 1] = (doublereal) (eh0001_._1) .ieh[0];
    isav[lenils + lenila + 2] = (doublereal) (eh0001_._1) .ieh[1];
    return 0;
}  

 
  int svcom1_(rsav, isav)
doublereal *rsav, *isav;
{
     

    static integer lenrls = 219;
    static integer lenils = 39;

     
    integer i__1;

     
    static integer i__;

 
 
 

 
 
 
 
     
    --isav;
    --rsav;

     

    i__1 = lenrls;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rsav[i__] = (ls0001_._5) .rls[i__ - 1];
    }
    i__1 = lenils;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	isav[i__] = (doublereal) (ls0001_._5) .ils[i__ - 1];
    }
    isav[lenils + 1] = (doublereal) (eh0001_._1) .ieh[0];
    isav[lenils + 2] = (doublereal) (eh0001_._1) .ieh[1];
    return 0;
}  

 
doublereal vmnorm_(n, v, w)
integer *n;
doublereal *v, *w;
{
     
    integer i__1;
    doublereal ret_val, d__1, d__2, d__3;

     
    static integer i__;
    static doublereal vm;

 
 
 

 
 
 
 
 
 

     
    --w;
    --v;

     
    vm = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__2 = vm, d__3 = (d__1 = v[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * w[i__];
	vm = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    }
    ret_val = vm;
    return ret_val;
 

}  

 
doublereal vnorm_(n, v, w)
integer *n;
doublereal *v, *w;
{
     
    integer i__1;
    doublereal ret_val, d__1;

     
    double sqrt();

     
    static integer i__;
    static doublereal sum;

 
 
 

 
 
 
 
 

 
     
    --w;
    --v;

     
    sum = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = v[i__] * w[i__];
	sum += d__1 * d__1;
    }
    ret_val = sqrt(sum / (doublereal) (*n));
    return ret_val;
 

}  

 
  int xerrwv_(msg, nmes, nerr, iert, ni, i1, i2, nr, r1, r2, 
	msg_len)
char *msg;
integer *nmes, *nerr, *iert, *ni, *i1, *i2, *nr;
doublereal *r1, *r2;
ftnlen msg_len;
{
     
    static char fmt_10[] = "(1x,80a1)";
    static char fmt_20[] = "(6x,\002where i1 is : \002,i10)";
    static char fmt_30[] = "(6x,\002where i1 is : \002,i10,3x,\002 and i2 : \002,i10)";
    static char fmt_40[] = "(6x,\002where i1 is : \002,d21.13)";
    static char fmt_50[] = "(6x,\002where i1 is : \002,d21.13,3x,\002and r2 : \002,d21.13)";

     
    integer i__1;

     
    integer i_len(), s_wsfe(), do_fio(), e_wsfe();
      int s_stop();

     
    static integer i__, nch, lun;

     
    static cilist io___1759 = { 0, 0, 0, fmt_10, 0 };
    static cilist io___1761 = { 0, 0, 0, fmt_20, 0 };
    static cilist io___1762 = { 0, 0, 0, fmt_30, 0 };
    static cilist io___1763 = { 0, 0, 0, fmt_40, 0 };
    static cilist io___1764 = { 0, 0, 0, fmt_50, 0 };


 

 
 
 
 
 

 
 

 
 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 
 
 

 
 

 
 
 
 

 

    if ((eh0001_._2) .mesflg == 0) {
	goto L100;
    }
 

    lun = (eh0001_._2) .lunit;
 

 
    i__1 = i_len(msg, msg_len);
    nch = (( i__1 ) <= ( 80 ) ? ( i__1 ) : ( 80 )) ;
 

    io___1759.ciunit = lun;
    s_wsfe(&io___1759);
    i__1 = nch;
    for (i__ = 1; i__ <= i__1; ++i__) {
	do_fio(&c__1, msg + (i__ - 1), 1L);
    }
    e_wsfe();
    if (*ni == 1) {
	io___1761.ciunit = lun;
	s_wsfe(&io___1761);
	do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*ni == 2) {
	io___1762.ciunit = lun;
	s_wsfe(&io___1762);
	do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*nr == 1) {
	io___1763.ciunit = lun;
	s_wsfe(&io___1763);
	do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*nr == 2) {
	io___1764.ciunit = lun;
	s_wsfe(&io___1764);
	do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 

L100:
    if (*iert != 2) {
	return 0;
    }
    s_stop("", 0L);
}  

 
  int xsetf_(mflag)
integer *mflag;
{

 
 
 

    if (*mflag == 0 || *mflag == 1) {
	(eh0001_._2) .mesflg = *mflag;
    }
    return 0;
 

}  

 
  int xsetun_(lun)
integer *lun;
{

 
 
 

    if (*lun > 0) {
	(eh0001_._2) .lunit = *lun;
    }
    return 0;
 

}  

 
  int ajour_(mode, n, nc, nr, h__, w, indi)
integer *mode, *n, *nc, *nr;
doublereal *h__, *w;
integer *indi;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    static doublereal a, b, c__;
    static integer i__, j, k;
    static doublereal u, v, h1;
    static integer nsaut, i1;
    static doublereal h2, ai, di;
    static integer ii, ij, ik, nh, nj, nk, nl, ko;
    static doublereal wi;
    static integer nw;
    static doublereal di1;
    static integer nh1, nr1, nr2, inc;
    static doublereal hij;
    static integer nii, nkk, nrr, inc1;


 
 
 
 
 
 

     
    --indi;
    --w;
    --h__;

     
    inc = indi[*nc];
    nr1 = *nr + 1;
    nr2 = *nr - 1;
    nrr = *n - *nr;
    nii = *n - inc;
    nkk = *nr - inc;
    if (*mode == -1) {
	goto L240;
    }

 

 
    nsaut = nii + 1;
    nh = inc * (*n + 1) - inc * (inc + 1) / 2;
    nw = *n;
    if (inc == *n) {
	goto L20;
    }
    i__1 = nii;
    for (i__ = 1; i__ <= i__1; ++i__) {
	w[nw] = h__[nh];
	--nw;
 
	--nh;
    }
L20:
    w[nr1] = h__[nh];
    --nh;
    if (inc == nr1) {
	goto L60;
    }
    i__1 = inc - nr1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nl = nii + i__ - 1;
	if (nl == 0) {
	    goto L35;
	}
	i__2 = nl;
	for (j = 1; j <= i__2; ++j) {
	    h__[nh + nsaut] = h__[nh];
 
	    --nh;
	}
L35:
	w[nw] = h__[nh];
	--nw;
	--nh;
 
	++nsaut;
    }
    i__1 = inc - nr1;
    for (j = 1; j <= i__1; ++j) {
	h__[nh + nsaut] = h__[nh];
 
	--nh;
    }

L60:
    --nw;
    nsaut = 1;
    if (*nr == 0) {
	goto L125;
    }
    if (inc == *n) {
	goto L80;
    }
    i__1 = nii;
    for (i__ = 1; i__ <= i__1; ++i__) {
	h__[nh + nsaut] = h__[nh];
 
	--nh;
    }
L80:
    if (*nr == 1) {
	goto L110;
    }
    i__1 = nr2;
    for (i__ = 1; i__ <= i__1; ++i__) {
	w[nw] = h__[nh];
	--nw;
	--nh;
	++nsaut;
	if (*n == nr1) {
	    goto L100;
	}
	i__2 = *n - nr1;
	for (j = 1; j <= i__2; ++j) {
	    h__[nh + nsaut] = h__[nh];
 
	    --nh;
	}
L100:
	;
    }
L110:
    w[nw] = h__[nh];
    --nh;
    ++nsaut;
    if (inc == nr1) {
	goto L125;
    }
    i__1 = inc - nr1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	h__[nh + nsaut] = h__[nh];
 
	--nh;
    }
 
L125:
    if (*nr != 0) {
	goto L130;
    }
    if (w[1] > 0.) {
	goto L220;
    }
    *mode = -1;
    return 0;
L130:
    if (*nr == 1) {
	goto L160;
    }
    i__1 = *nr;
    for (i__ = 2; i__ <= i__1; ++i__) {
	ij = i__;
	i1 = i__ - 1;
	v = w[i__];
	i__2 = i1;
	for (j = 1; j <= i__2; ++j) {
	    v -= h__[ij] * w[j];
 
	    ij = ij + *nr - j;
	}
 
	w[i__] = v;
    }
L160:
    ij = 1;
    v = w[nr1];
    i__1 = *nr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	wi = w[i__];
	hij = h__[ij];
 
	d__1 = wi;
	v -= d__1 * d__1 / hij;
	w[i__] = wi / hij;
 
	ij = ij + nr1 - i__;
    }
    if (v > 0.) {
	goto L180;
    }
    *mode = -1;
    return 0;
L180:
    w[nr1] = v;
 
    nh = *nr * (*nr + 1) / 2;
    nw = nr1;
    nsaut = nw;
    h__[nh + nsaut] = w[nw];
    --nw;
    --nsaut;
    if (*nr == 1) {
	goto L220;
    }
    i__1 = nr2;
    for (i__ = 1; i__ <= i__1; ++i__) {
	h__[nh + nsaut] = w[nw];
	--nw;
	--nsaut;
	i__2 = i__;
	for (j = 1; j <= i__2; ++j) {
	    h__[nh + nsaut] = h__[nh];
 
	    --nh;
	}
 
    }
L220:
    h__[nr1] = w[1];
    if (*n == nr1) {
	goto L233;
    }
    nh1 = *nr * (*n + 1) - *nr * (*nr + 1) / 2 + 1;
    nw = nr1;
    i__1 = *n - nr1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	h__[nh1 + i__] = w[nw + i__];
    }
 
L233:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ii = indi[i__];
	if (ii <= *nr || ii >= inc) {
	    goto L235;
	}
	indi[i__] = ii + 1;
L235:
	;
    }
    ++(*nr);
    indi[*nc] = *nr;
    *mode = 0;
    return 0;

 

 
L240:
    i__1 = *nr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ik = i__;
	ij = inc;
	ii = 1;
	ko = (( ik ) <= ( inc ) ? ( ik ) : ( inc )) ;
	v = 0.;
	if (ko == 1) {
	    goto L252;
	}
	i__2 = ko - 1;
	for (k = 1; k <= i__2; ++k) {
	    nk = nr1 - k;
	    v += h__[ij] * h__[ik] * h__[ii];
	    ij = ij + nk - 1;
	    ii += nk;
 
	    ik = ik + nk - 1;
	}
L252:
	a = 1.;
	b = 1.;
	if (ko == i__) {
	    goto L253;
	}
	a = h__[ik];
L253:
	if (ko == inc) {
	    goto L260;
	}
	b = h__[ij];
L260:
	w[i__] = v + a * b * h__[ii];
    }
 
    if (inc == *nr) {
	goto L315;
    }
    inc1 = inc - 1;
    nh = inc1 * nr1 - inc1 * inc / 2 + 2;
    nh1 = nh + nkk;
    di = h__[nh - 1];
    i__1 = nkk;
    for (j = 1; j <= i__1; ++j) {
	di1 = h__[nh1];
	++nh1;
	a = h__[nh];
	ai = a * di;
 
	d__1 = a;
	c__ = d__1 * d__1 * di + di1;
	h__[nh] = c__;
	++nh;
	if (j == nkk) {
	    goto L315;
	}
	i__2 = nkk - j;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    h1 = h__[nh];
	    h2 = h__[nh1];
	    u = ai * h1 + h2 * di1;
	    h__[nh] = u / c__;
	    h__[nh1] = -h1 + a * h2;
	    ++nh;
	    ++nh1;
 
	}
	++nh;
	di = di * di1 / c__;
 
    }
 
L315:
    nh = inc + 1;
    nsaut = 1;
    nj = *nr - 2;
    if (inc == 1) {
	++nj;
    }
    if (*nr == 1) {
	goto L440;
    }
    i__1 = nr2;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = nj;
	for (j = 1; j <= i__2; ++j) {
	    h__[nh - nsaut] = h__[nh];
 
	    ++nh;
	}
	++nsaut;
	++nh;
	if (i__ == inc - 1) {
	    goto L430;
	}
	--nj;
	if (nj == 0) {
	    goto L440;
	}
L430:
	;
    }
 
L440:
    nh = *nr * nr2 / 2 + 1;
    nw = 1;
    nsaut = *nr;
    if (inc == 1) {
	goto L470;
    }
    i__1 = inc - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	h__[nh] = w[nw];
	++nw;
	--nsaut;
	if (*n == *nr) {
	    goto L455;
	}
	i__2 = nrr;
	for (j = 1; j <= i__2; ++j) {
 
	    h__[nh + j] = h__[nh + nsaut + j];
	}
L455:
	nh = nh + nrr + 1;
 
    }
L470:
    ++nw;
    if (*nr == *n) {
	goto L485;
    }
    i__1 = nrr;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	w[*nr + i__] = h__[nh + nsaut + i__ - 1];
    }
    nsaut += nrr;
L485:
    if (inc == *nr) {
	goto L510;
    }
    i__1 = nkk;
    for (i__ = 1; i__ <= i__1; ++i__) {
	--nsaut;
	h__[nh] = w[nw];
	++nw;
	if (*nr == *n) {
	    goto L495;
	}
	i__2 = nrr;
	for (j = 1; j <= i__2; ++j) {
 
	    h__[nh + j] = h__[nh + nsaut + j];
	}
L495:
	nh = nh + nrr + 1;
 
    }
L510:
    h__[nh] = w[inc];
    if (*nr == *n) {
	goto L540;
    }
    i__1 = nrr;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	h__[nh + i__] = w[*nr + i__];
    }
 
L540:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ii = indi[i__];
	if (ii <= inc || ii > *nr) {
	    goto L550;
	}
	indi[i__] = ii - 1;
L550:
	;
    }
    indi[*nc] = *nr;
    --(*nr);
    *mode = 0;
    return 0;
}  

  int anfm01_(q, iq, r__, ir, x, w, n, m, ind, io)
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *x, *w;
integer *n, *m, *ind, *io;
{
     
    integer q_dim1, q_offset, r_dim1, r_offset, i__1;
    doublereal d__1;

     
    double pow_dd(), d_sign(), sqrt();

     
    extern doublereal ddot_(), dnrm2_();
    static integer i__, j, k;
    static doublereal s, t;
    extern   int dscal_(), dcopy_(), daxpy_();
    static integer m1;
    extern doublereal dlamch_();
    static integer nm;
    static doublereal rnorma, eps;

     
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --x;
    --w;

     
    m1 = *m - 1;
    nm = *n - m1;
    k = 0;
    if (*ind < 0) {
	k = 1;
	*ind = -(*ind);
    }
    if (*ind == 0) {
	i__1 = m1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    r__[i__ + *m * r_dim1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[
		    1], &c__1);
	}
	i__1 = *n;
	for (i__ = *m; i__ <= i__1; ++i__) {
 
	    w[i__ - m1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[1], &c__1);
	}
    } else {
	dcopy_(&m1, &q[*ind + q_dim1], iq, &r__[*m * r_dim1 + 1], &c__1);
	dcopy_(&nm, &q[*ind + *m * q_dim1], iq, &w[1], &c__1);
    }
    if (k == 1) {
	i__1 = m1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    r__[i__ + *m * r_dim1] = -r__[i__ + *m * r_dim1];
	}
	i__1 = nm;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[i__] = -w[i__];
	}
    }

 

 

    rnorma = dnrm2_(&nm, &w[1], &c__1);
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5732);
    if (rnorma < eps) {
	*ind = -1;
	return 0;
    }

 

 

    *ind = 0;
    if (*m == *n) {
	r__[*m + *m * r_dim1] = w[1];
	return 0;
    }
    if (w[1] != 0.) {
	rnorma = d_sign(&rnorma, &w[1]);
    }
    w[1] = rnorma + w[1];
    s = sqrt(w[1] * rnorma);
    s = 1 / s;
    dscal_(&nm, &s, &w[1], &c__1);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	t = -ddot_(&nm, &w[1], &c__1, &q[j + *m * q_dim1], iq);
	daxpy_(&nm, &t, &w[1], &c__1, &q[j + *m * q_dim1], iq);
 
    }
    r__[*m + *m * r_dim1] = -rnorma;
}  

  int anfm02_(q, iq, r__, ir, n, m, icol, io)
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir, *n, *m, *icol, *io;
{
     
    integer q_dim1, q_offset, r_dim1, r_offset, i__1, i__2;
    doublereal d__1;

     
    double d_sign();

     
    extern doublereal dnrm2_();
    static doublereal a;
    static integer i__, j;
    static doublereal s, t;
    extern   int dscal_(), dcopy_();
    static integer i1;
    static doublereal s1, s2;
    extern doublereal dlamch_();
    static doublereal epsmch;

     
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;

     
    if (*m == *icol) {
	return 0;
    }

 


    epsmch = dlamch_("p", 1L);
    i__1 = *m;
    for (i__ = *icol + 1; i__ <= i__1; ++i__) {
	if (r__[i__ + i__ * r_dim1] != 0.) {
	    i1 = i__ - 1;
	    a = dnrm2_(&c__2, &r__[i1 + i__ * r_dim1], &c__1);
	    if (a > epsmch) {
		if (r__[i1 + i__ * r_dim1] != 0.) {
		    a = d_sign(&a, &r__[i1 + i__ * r_dim1]);
		}
		d__1 = 1. / a;
		dscal_(&c__2, &d__1, &r__[i1 + i__ * r_dim1], &c__1);
		r__[i1 + i__ * r_dim1] += 1.;
		s1 = r__[i1 + i__ * r_dim1];
		s2 = r__[i__ + i__ * r_dim1];
		s = s2 / s1;
		i__2 = *n;
		for (j = 1; j <= i__2; ++j) {
		    t = -q[j + i1 * q_dim1] - q[j + i__ * q_dim1] * s;
		    q[j + i1 * q_dim1] += t * s1;
		    q[j + i__ * q_dim1] += t * s2;
 
		}
		i__2 = *m;
		for (j = i__ + 1; j <= i__2; ++j) {
		    t = -r__[i1 + j * r_dim1] - r__[i__ + j * r_dim1] * s;
		    r__[i1 + j * r_dim1] += t * s1;
		    r__[i__ + j * r_dim1] += t * s2;
 
		}
		r__[i1 + i__ * r_dim1] = -a;
	    }
	}
 
    }

 

    i__1 = *m;
    for (j = *icol + 1; j <= i__1; ++j) {
	i1 = j - 1;
	dcopy_(&i1, &r__[j * r_dim1 + 1], &c__1, &r__[i1 * r_dim1 + 1], &c__1)
		;
 
    }
}  

  int anfm03_(h__, ih, r__, ir, z__, iz, w, ipvt, n, m, ind, 
	modo, io)
doublereal *h__;
integer *ih;
doublereal *r__;
integer *ir;
doublereal *z__;
integer *iz;
doublereal *w;
integer *ipvt, *n, *m, *ind, *modo, *io;
{
     
    integer h_dim1, h_offset, r_dim1, r_offset, z_dim1, z_offset, i__1, i__2, 
	    i__3, i__4;
    doublereal d__1, d__2;

     
    double sqrt();

     
    static doublereal beta;
    static integer ndim;
    extern doublereal ddot_();
    static doublereal smax;
    extern doublereal zthz_();
    static integer i__, j, k, l;
    static doublereal s;
    static integer i1;
    static doublereal s1;
    static integer ii, ij, ik, kk, in;
    extern doublereal dlamch_();
    static integer nj, iibeta;
    static doublereal sk, epsmch;
    extern   int dipvtf_();
    static integer ik0, nm1;
    static doublereal rii, rik, eps, eps0;


 

 

 

 

 

 

 
 

 

 

 

 
 

 


 
 
 

 
 



 

 

 
 
 
 

 

     
    h_dim1 = *ih;
    h_offset = h_dim1 + 1;
    h__ -= h_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    z_dim1 = *iz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --w;
    --ipvt;

     
    epsmch = dlamch_("p", 1L);
    eps = epsmch * 10.;
    if (*ind == 0) {
	ndim = *m;
	i__1 = ndim;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    ipvt[i__] = i__;
	}
    } else {
	ndim = *m - *ind;
    }
    smax = 1.;
    nm1 = *m + 1;

 

    i__1 = ndim;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*ind == 0) {
	    nj = nm1 - i__;
	    ii = i__;
	} else {
	    nj = nm1 - ipvt[i__];
	    ii = *ind + i__;
	}
	s = zthz_(&h__[h_offset], ih, &z__[z_offset], iz, n, &nj, &nj);
	if (*ind > 0) {
	    s -= ddot_(ind, &r__[i__ * r_dim1 + 1], &c__1, &r__[i__ * r_dim1 
		    + 1], &c__1);
	}
	if (*modo == 0 && s < -eps) {
	    *ind = *n;
	    return 0;
	}
	r__[ii + i__ * r_dim1] = s;
	s = (( s ) >= 0 ? ( s ) : -( s )) ;
	smax = (( s ) >= ( smax ) ? ( s ) : ( smax )) ;
 
    }

 

    if (ndim == 1) {
	ik = *ind + 1;
	s = r__[ik + r_dim1];
	if (s > eps) {
	    r__[ik + r_dim1] = sqrt(s);
	    *ind = 0;
	} else if (s < -eps) {
	    *ind = -1;
	} else {
	    *ind = 1;
	}
	return 0;
    }

 

    eps0 = epsmch * smax;
    eps = eps0 * *ind;
 
    d__1 = eps0 * ndim * 10, d__2 = sqrt(smax) * 1.2;
    beta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    iibeta = 0;
    s1 = 0.;
    i__1 = ndim - 1;
    for (k = 1; k <= i__1; ++k) {
	eps += eps0;
	kk = k + 1;
	ik = k;
	if (*ind > 0) {
	    ik = k + *ind;
	}
	ik0 = ik - 1;
	sk = r__[ik + k * r_dim1];
	if (s1 <= beta) {
	    j = k;
	    s = sk;
	    i__2 = ndim;
	    for (i__ = kk; i__ <= i__2; ++i__) {
		ii = i__ + *ind;
		rii = r__[ii + i__ * r_dim1];
		if (rii > s) {
		    j = i__;
		    s = rii;
		}
 
	    }
	} else {
	    s = -1.;
	    iibeta = 1;
	}

 

 

	if (s > eps) {
	    dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &k, &j);
	    r__[*ind + j + j * r_dim1] = sk;
	    l = nm1 - ipvt[k];
	    sk = sqrt(s);
	    r__[ik + k * r_dim1] = sk;
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		s = ddot_(&i__, &h__[i__ + h_dim1], ih, &z__[l * z_dim1 + 1], 
			&c__1);
		if (i__ < *n) {
		    i1 = i__ + 1;
		    i__3 = *n - i__;
		    w[i__] = s + ddot_(&i__3, &h__[i1 + i__ * h_dim1], &c__1, 
			    &z__[i1 + l * z_dim1], &c__1);
		}
 
	    }
	    w[*n] = s;
	    s1 = 0.;
	    i__2 = ndim;
	    for (i__ = kk; i__ <= i__2; ++i__) {
		j = nm1 - ipvt[i__];
		s = ddot_(n, &z__[j * z_dim1 + 1], &c__1, &w[1], &c__1);
		if (ik0 > 0) {
		    s -= ddot_(&ik0, &r__[i__ * r_dim1 + 1], &c__1, &r__[k * 
			    r_dim1 + 1], &c__1);
		}
		rik = s / sk;
 
		d__1 = s1, d__2 = (( rik ) >= 0 ? ( rik ) : -( rik )) ;
		s1 = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
		r__[ik + i__ * r_dim1] = rik;
		ii = i__;
		if (*ind > 0) {
		    ii += *ind;
		}
		r__[ii + i__ * r_dim1] -= rik * rik;
 
	    }
	} else {

 


	    s = sk;
	    j = k;
	    i__2 = ndim;
	    for (i__ = kk; i__ <= i__2; ++i__) {
		ii = *ind + i__;
		rii = r__[ii + i__ * r_dim1];
		if (rii < s) {
		    j = i__;
		    s = rii;
		}
 
	    }

 

 

	    if (s < -eps) {
		if (*modo == 0) {
		    *ind = *n;
		    return 0;
		}
		dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &k, &j);
		r__[ik + k * r_dim1] = s;
		r__[*ind + j + j * r_dim1] = sk;
		*ind = -k;
		if (iibeta == 1) {
		    *ind -= *iz * 10;
		}
		return 0;
	    } else {

 

 

		i__2 = ndim - 1;
		for (j = k; j <= i__2; ++j) {
		    nj = nm1 - ipvt[j];
		    ij = j + *ind;
		    i__3 = *n;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			s1 = ddot_(&i__, &h__[i__ + h_dim1], ih, &z__[nj * 
				z_dim1 + 1], &c__1);
			if (i__ < *n) {
			    i1 = i__ + 1;
			    i__4 = *n - i__;
			    w[i__] = s1 + ddot_(&i__4, &h__[i1 + i__ * h_dim1]
				    , &c__1, &z__[i1 + nj * z_dim1], &c__1);
			}
 
		    }
		    w[*n] = s1;
		    i__3 = ndim;
		    for (i__ = j + 1; i__ <= i__3; ++i__) {
			s1 = ddot_(n, &w[1], &c__1, &z__[(nm1 - ipvt[i__]) * 
				z_dim1 + 1], &c__1);
			if (ik0 > 0) {
			    s1 -= ddot_(&ik0, &r__[i__ * r_dim1 + 1], &c__1, &
				    r__[j * r_dim1 + 1], &c__1);
			}
			r__[ij + i__ * r_dim1] = s1;
			s1 = (( s1 ) >= 0 ? ( s1 ) : -( s1 )) ;
			if (s1 > s) {
			    s = s1;
			    l = i__;
			}
 
		    }

 

 


		    if (s > eps) {
			if (*modo == 0) {
			    *ind = *n;
			    return 0;
			}
			dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &j, &k);
			dipvtf_(&r__[r_offset], ir, &ipvt[1], &ik0, &l, &kk);
			r__[ik + kk * r_dim1] = r__[ij + l * r_dim1];
			*ind = -ndim - k;
			return 0;
		    }
 
		}

 

 

		*ind = ndim - k + 1;
		return 0;
	    }
	}
 
    }

 

    eps = eps0 + eps;
    in = ndim + *ind;
    s = r__[in + ndim * r_dim1];
    if (s > eps) {
	r__[in + ndim * r_dim1] = sqrt(s);
	*ind = 0;
    } else if (s < -eps) {
	*ind = -ndim;
    } else {
	*ind = 1;
    }
}  

  int anfm04_(q, iq, r__, ir, x, w, ipvt, n, m, ind, io)
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *x, *w;
integer *ipvt, *n, *m, *ind, *io;
{
     
    integer q_dim1, q_offset, r_dim1, r_offset, i__1, i__2;

     
    double pow_dd(), sqrt();

     
    extern doublereal ddot_(), dnrm2_();
    static doublereal a, b, c__;
    static integer i__, j, k;
    static doublereal s, t;
    extern   int dcopy_();
    static integer i1, j1, k1, k2, m1, m2, m3, n1, j2;
    extern doublereal dlamch_();
    static integer nm;
    static doublereal epsmch, rnorma;
    static integer nm1;
    static doublereal eps, eps0;

     
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --x;
    --w;
    --ipvt;

     
    epsmch = dlamch_("p", 1L);
    eps = pow_dd(&epsmch, &c_b5779);
    eps0 = pow_dd(&epsmch, &c_b5732);
    nm = *n - *m;
    nm1 = nm + 1;
    m1 = *m - 1;
    m2 = (nm << 1) + 1;
    m3 = m2 - *m;
    n1 = *n + 1;

 

    k = 0;
    if (*ind < 0) {
	k = 1;
	*ind = -(*ind);
    }
    if (*ind == 0) {
	i__1 = m1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    r__[i__ + *m * r_dim1] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[
		    1], &c__1);
	}
	i__1 = *n;
	for (i__ = *m; i__ <= i__1; ++i__) {
 
	    w[m3 + i__] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &x[1], &c__1);
	}
    } else {
	dcopy_(&m1, &q[*ind + q_dim1], iq, &r__[*m * r_dim1 + 1], &c__1);
	dcopy_(&nm1, &q[*ind + *m * q_dim1], iq, &w[m2], &c__1);
    }
    if (k == 1) {
	i__1 = m1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    r__[i__ + *m * r_dim1] = -r__[i__ + *m * r_dim1];
	}
	i__1 = m2 + nm;
	for (i__ = m2; i__ <= i__1; ++i__) {
 
	    w[i__] = -w[i__];
	}
    }

 

 

    rnorma = dnrm2_(&nm1, &w[m2], &c__1);
    if (rnorma < eps0) {
	*ind = -1;
	return 0;
    }

 

 

    *ind = 0;
    if (*m == *n) {
	r__[*m + *m * r_dim1] = w[m2];
	return 0;
    }
    k1 = n1 - ipvt[1];
    i__1 = nm1;
    for (i__ = 2; i__ <= i__1; ++i__) {
	i1 = i__ - 1;
	k2 = n1 - ipvt[i__];
	if (k2 < k1) {
	    j = k1;
	    k1 = k2;
	    k2 = j;
	}
	j1 = m3 + k1;
	j2 = m3 + k2;
	t = sqrt(w[j1] * w[j1] + w[j2] * w[j2]);
	if (t < eps) {
	    w[i1] = 1.;
	    w[nm + i1] = 0.;
	    i__2 = *n;
	    for (j = 1; j <= i__2; ++j) {
 
		q[j + k2 * q_dim1] = -q[j + k2 * q_dim1];
	    }
	} else {
	    c__ = w[j1] / t;
	    s = w[j2] / t;
	    w[j1] = t;
	    w[j2] = 0.;
	    i__2 = *n;
	    for (j = 1; j <= i__2; ++j) {
		a = q[j + k1 * q_dim1];
		b = q[j + k2 * q_dim1];
		q[j + k1 * q_dim1] = a * c__ + b * s;
		q[j + k2 * q_dim1] = a * s - b * c__;
 
	    }
	    w[i1] = c__;
	    w[nm + i1] = s;
	}
 
    }
    r__[*m + *m * r_dim1] = t;
}  

  int anfm05_(h__, ih, r__, ir, z__, iz, p, w, ipvt, x, n, m, 
	np, ind, modo, io)
doublereal *h__;
integer *ih;
doublereal *r__;
integer *ir;
doublereal *z__;
integer *iz;
doublereal *p, *w;
integer *ipvt;
doublereal *x;
integer *n, *m, *np, *ind, *modo, *io;
{
     
    integer h_dim1, h_offset, r_dim1, r_offset, z_dim1, z_offset, i__1, i__2;
    doublereal d__1;

     
    double sqrt();

     
    static doublereal c__;
    static integer i__, j, k, l;
    static doublereal s;
    extern   int anfm03_(), dcopy_(), dswap_();
    static integer i1, j1, k1, k2, m1, n1, m2, n2, m3;
    static doublereal s1;
    static integer ni;
    extern doublereal dlamch_();
    static doublereal pi, ri;
    static integer iibeta;
    static doublereal epsmch;
    extern   int dipvtf_();
    static integer ni1;
    static doublereal ri1;
    static integer nm2;
    static doublereal rj1, rij, pni;
     
    h_dim1 = *ih;
    h_offset = h_dim1 + 1;
    h__ -= h_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    z_dim1 = *iz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --p;
    --w;
    --ipvt;

     
    n1 = *n + 1;
    epsmch = dlamch_("p", 1L);
    if (*ind == n1) {
	--(*ind);
	return 0;
    }

 

    if (*ind > 0 && *ind <= n1) {
	m2 = n1 - *ind;
    } else {
	m2 = *m;
    }
    m1 = m2 + 1;

 

    n2 = n1 + 1;
    nm2 = n1 + m2;
    k1 = ipvt[1];
    if (m2 > 0) {
	w[1] = *x;
    } else {
	w[1] = 1.;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__ + 1;
	ni1 = n1 + i1;
	k2 = ipvt[i1];
	ni = *n + i__;
	pni = p[ni];
	pi = p[i__];
	if (i__ < m2) {
	    l = i1;
	} else {
	    l = m2;
	}
	dcopy_(&l, &r__[i__ * r_dim1 + 1], &c__1, &w[n2], &c__1);
	if (k1 < k2) {
	    j = k1;
	    k1 = k2;
	    k2 = j;
	    i__2 = i1;
	    for (k = m1; k <= i__2; ++k) {
 
		w[n1 + k] = 0.;
	    }
	    if (i__ > *m) {
		w[ni1] = 1.;
	    }
	    dswap_(&i1, &w[1], &c__1, &w[n2], &c__1);
	    j = -1;
	} else {
	    j = 0;
	}
	if (i__ < m2) {
	    --l;
	}
	ipvt[i__] = k2;
	i__2 = l;
	for (k = 2; k <= i__2; ++k) {
 
	    r__[k - 1 + i__ * r_dim1] = w[k] * pni - w[n1 + k] * pi;
	}
	if (i__ < *m) {
	    if (i__ < m2) {
		r__[i1 + i__ * r_dim1] = w[1] * pni - w[n2] * pi;
	    } else {
		r__[m2 + i__ * r_dim1] = w[1] * pni - w[n2] * pi;
	    }
	    i__2 = l;
	    for (k = 1; k <= i__2; ++k) {
 
		w[k] = w[k] * pi + w[n1 + k] * pni;
	    }
	}
	if (i__ < m2) {
	    if (j == 0) {
		r__[i__ + i__ * r_dim1] = -pi * w[ni1];
		w[i1] = pni * w[ni1];
	    } else {
		r__[i__ + i__ * r_dim1] = pni * w[i1];
		w[i1] = pi * w[i1];
	    }
	} else if (i__ >= *m) {

 

	    r__[m2 + i__ * r_dim1] = w[1] * pni - w[n2] * pi;
	    i__2 = l;
	    for (k = 1; k <= i__2; ++k) {
 
		w[k] = w[k] * pi + w[n1 + k] * pni;
	    }
	}
 
    }

 

    m3 = m2 - 1;
    i__1 = m3;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__ + 1;
	ri = r__[i__ + i__ * r_dim1];
	ri1 = r__[i1 + i__ * r_dim1];
	if ((( ri1 ) >= 0 ? ( ri1 ) : -( ri1 ))  > epsmch) {
	    s1 = sqrt(ri1 * ri1 + ri * ri);
	    s = ri1 / s1;
	    c__ = ri / s1;
	    r__[i__ + i__ * r_dim1] = s1;
	    i__2 = *n;
	    for (j = i1; j <= i__2; ++j) {
		if (j <= m3) {
		    j1 = j + 1;
		} else {
		    j1 = m2;
		}
		rj1 = r__[j1 + j * r_dim1];
		rij = r__[i__ + j * r_dim1];
		r__[i__ + j * r_dim1] = c__ * rij + s * rj1;
		r__[j1 + j * r_dim1] = s * rij - c__ * rj1;
 
	    }
	}
 
    }

 

    if (*ind > 0 && *ind <= n1) {
	j = m2;
	s = (d__1 = r__[m2 + m2 * r_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	i__1 = *n;
	for (i__ = m2 + 1; i__ <= i__1; ++i__) {
	    s1 = (d__1 = r__[m2 + i__ * r_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (s1 > s) {
		s = s1;
		j = i__;
	    }
 
	}
	if (r__[m2 + j * r_dim1] < -epsmch) {
	    i__1 = *n;
	    for (i__ = m2; i__ <= i__1; ++i__) {
 
		r__[m2 + i__ * r_dim1] = -r__[m2 + i__ * r_dim1];
	    }
	}
	if (j != m2) {
	    dipvtf_(&r__[r_offset], ir, &ipvt[1], &m2, &m2, &j);
	}
    }
    if (*ind >= 0 && *ind <= n1) {
	if (*ind > 0 && r__[m2 + m2 * r_dim1] > epsmch) {
	    --(*ind);
	}
	return 0;
    }

 

    *ind = m3;
    anfm03_(&h__[h_offset], ih, &r__[m2 * r_dim1 + 1], ir, &z__[z_offset], iz,
	     &w[1], &ipvt[m2], np, n, ind, modo, io);

 

    if (*ind <= *iz * -10) {
	iibeta = 1;
	*ind += *iz * 10;
    } else {
	iibeta = 0;
    }
    k2 = *n - m3;
    if (*ind < 0 && *ind >= -k2) {
	*ind -= m3;
    } else if (*ind < -k2) {
	*ind -= m3 << 1;
    }
    if (iibeta == 1) {
	*ind -= *iz * 10;
    }
}  

 
  int anfm06_(z__, iz, r__, ir, w, ipvt, n, m, ind, io)
doublereal *z__;
integer *iz;
doublereal *r__;
integer *ir;
doublereal *w;
integer *ipvt, *n, *m, *ind, *io;
{
     
    integer z_dim1, z_offset, r_dim1, r_offset, i__1, i__2;
    doublereal d__1;

     
    double pow_dd(), sqrt();

     
    extern doublereal ddot_(), dnrm2_();
    static integer i__, j, k;
    static doublereal s;
    extern   int anrs01_(), dcopy_();
    static integer i1, k1, m1, n1, m2, m3;
    extern doublereal dlamch_();
    static integer nm;
    static doublereal epsmch;
    extern   int dipvtf_();
    static doublereal rnorma;
    static integer nm1;


 

 
 

 
 
 

 

 


 
 
 

 
 



 

 
 
 
 

 

     
    z_dim1 = *iz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --w;
    --ipvt;

     
    d__1 = dlamch_("p", 1L);
    epsmch = pow_dd(&d__1, &c_b5779);
    n1 = *n + 1;
    m1 = *m + 1;
    m2 = m1 + 1;
    nm = n1 - *m;

 

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__ + 1;
	s = ddot_(&i__, &r__[i__ + r_dim1], ir, &z__[z_dim1 + 1], &c__1);
	if (i__ < *n) {
	    i__2 = *n - i__;
	    w[i__] = s + ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, &z__[i1 
		    + z_dim1], &c__1);
	}
 
    }
    w[*n] = s;

 

    s = ddot_(n, &w[1], &c__1, &z__[z_dim1 + 1], &c__1);

 

 


    k = 0;
    i__1 = nm + *m - 1;
    for (i__ = nm; i__ <= i__1; ++i__) {
	++k;
	dcopy_(&k, &r__[(i__ + 1) * r_dim1 + 1], &c__1, &r__[i__ * r_dim1 + 1]
		, &c__1);
 
    }

 

 

    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	r__[i__ + n1 * r_dim1] = ddot_(n, &w[1], &c__1, &z__[(m2 - i__) * 
		z_dim1 + 1], &c__1);
    }
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	w[i__] = r__[ipvt[i__] + n1 * r_dim1];
    }
    ipvt[m1] = m1;

 

 

    m3 = *m - *ind;
    if (m3 > 0) {
	anrs01_(&r__[nm * r_dim1 + 1], ir, &m3, &w[1], &r__[n1 * r_dim1 + 1], 
		&c__1, io);
	s -= ddot_(&m3, &r__[n1 * r_dim1 + 1], &c__1, &r__[n1 * r_dim1 + 1], &
		c__1);
    }

 

 

    k1 = 0;
    if (*ind > 0) {
	k = *n - *ind;
	if (m3 > 0) {
	    i__1 = *ind;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		j = m3 + i__;
		r__[j + n1 * r_dim1] = w[j] - ddot_(ind, &r__[(k + i__) * 
			r_dim1 + 1], &c__1, &r__[n1 * r_dim1 + 1], &c__1);
 
	    }
	} else {
	    dcopy_(ind, &w[1], &c__1, &r__[n1 * r_dim1 + 1], &c__1);
	}
	rnorma = dnrm2_(ind, &r__[m3 + 1 + n1 * r_dim1], &c__1);
	if (rnorma < epsmch) {
	    k1 = 1;
	}
    }

 
 

    if (s > epsmch) {
	s = sqrt(s);
	r__[m1 + n1 * r_dim1] = s;
	if (*ind > 0) {
	    if (k1 == 0) {
		i__1 = *m;
		for (i__ = m3 + 1; i__ <= i__1; ++i__) {
 
		    r__[i__ + n1 * r_dim1] /= s;
		}
		*ind += m1 << 1;
	    }
	    m2 = m3 + 1;
	    dipvtf_(&r__[nm * r_dim1 + 1], ir, &ipvt[1], &m3, &m1, &m2);
	    nm1 = n1 - *m;
	    r__[m2 + (m2 + *n - *m) * r_dim1] = s;
	    i__1 = *m;
	    for (i__ = m2; i__ <= i__1; ++i__) {
 
		r__[m2 + (i__ + nm1) * r_dim1] = r__[i__ + n1 * r_dim1];
	    }
	}
    } else {
	r__[m1 + n1 * r_dim1] = s;
	if (s < -epsmch) {
	    if (*ind == 0) {
		*ind = -m1;
	    } else {
		*ind = *ind + 1 + m1;
	    }
	} else {
	    if (*ind == 0) {
		*ind = 1;
	    } else if (k1 == 1) {
		++(*ind);
	    } else {
		*ind = *ind + 1 + m1;
	    }
	}
    }
    *m = m1;
}  

  int anrs01_(r__, ir, m, b, x, ind, io)
doublereal *r__;
integer *ir, *m;
doublereal *b, *x;
integer *ind, *io;
{
     
    integer r_dim1, r_offset, i__1;

     
    extern doublereal ddot_();
    static integer i__, j, k, i1, j1, j2, j3;


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 

 

 
 

 

 

 

 

 


 

 

 
 
 

 

 

 
 

 
 
 

 
 


 
 
 
 

 
 
 
 
 
 

 
 
 

 

     
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --b;
    --x;

     
    if (*ind == 1) {
	j = 1;
    } else {
	j = *m;
    }
 
 
 
 
    x[j] = b[j] / r__[j + j * r_dim1];
    if (*m == 1) {
	return 0;
    }
    i__1 = *m;
    for (i__ = 2; i__ <= i__1; ++i__) {
	i1 = i__ - 1;
	if (*ind == 1) {
	    j = i__;
	    j1 = 1;
	    j2 = i__;
	    j3 = 1;
	    k = 1;
	} else {
	    j = *m - i1;
	    j1 = j;
	    j2 = j + 1;
	    j3 = j2;
	    k = *ir;
	}
 
 
 
 
	x[j] = (b[j] - ddot_(&i1, &r__[j1 + j2 * r_dim1], &k, &x[j3], &c__1)) 
		/ r__[j + j * r_dim1];
 
    }
 
}  

  int anrs02_(a, ia, b, w, ipvt, n, io)
doublereal *a;
integer *ia;
doublereal *b, *w;
integer *ipvt, *n, *io;
{
     
    integer a_dim1, a_offset, i__1;

     
    static integer i__;
    extern   int anrs01_();
    static integer ind;


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 
 
 
 

 
 

 
 
 

 

 

 

 

 

 

 
 

 
 


 

 

 


 
 
 

 
 



 

     
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --b;
    --w;
    --ipvt;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	w[i__] = b[ipvt[i__]];
    }
    ind = 1;
    anrs01_(&a[a_offset], ia, n, &w[1], &w[1], &ind, io);

 

    ind = 2;
    anrs01_(&a[a_offset], ia, n, &w[1], &w[1], &ind, io);

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	b[ipvt[i__]] = w[i__];
    }
}  

  int aux003_(a, ia, x, b, q, iq, r__, ir, w, ire, ipvt, nmd, 
	mif, mdf, midf, n, m, ind, io)
doublereal *a;
integer *ia;
doublereal *x, *b, *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *w;
integer *ire, *ipvt, *nmd, *mif, *mdf, *midf, *n, *m, *ind, *io;
{
     
    integer a_dim1, a_offset, q_dim1, q_offset, r_dim1, r_offset, i__1;
    doublereal d__1;

     
    double pow_dd();

     
    extern doublereal ddot_();
    static integer info, i__;
    static doublereal s;
    extern   int anfm01_();
    static integer m1, mf, ni;
    extern doublereal dlamch_();
    static doublereal eps;
     
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --x;
    --b;
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --w;
    --ire;
    --ipvt;

     
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);
    mf = *midf + 1;
    info = 1;
    i__1 = *mif;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (ire[i__] != 1) {
	    s = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1) - b[i__];
	    if ((( s ) >= 0 ? ( s ) : -( s ))  < eps) {
		if (*m < *n && *ind == 0) {
		    m1 = *m + 1;
		    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &a[i__ * 
			    a_dim1 + 1], &w[mf], n, &m1, ind, io);
		    if (*ind < 0) {
			ire[i__] = 0;
			*ind = 0;
		    } else {
			*m = m1;
			ipvt[*m] = *nmd + i__;
			ire[i__] = 1;
		    }
		} else {
		    if (ire[i__] != 0) {
			info = 0;
		    }
		    ire[i__] = 0;
		}
	    } else if (s >= eps) {
		ire[i__] = 2;
		w[i__] = s;
	    } else {
		ire[i__] = -2;
		w[i__] = s;
	    }
	}
 
    }
    i__1 = *mdf;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ni = *mif + i__;
	if (ire[ni] != 1) {
	    s = ddot_(n, &a[ni * a_dim1 + 1], &c__1, &x[1], &c__1) - b[ni];
	    if (s > eps) {
		ire[ni] = 2;
	    } else if (s < -eps || *ind == 1) {
		if (ire[ni] != 0) {
		    info = 0;
		}
		ire[ni] = 0;
	    } else {
		if (*m < *n) {
		    m1 = *m + 1;
		    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &a[ni * 
			    a_dim1 + 1], &w[mf], n, &m1, ind, io);
		    if (*ind < 0) {
			ire[ni] = 0;
			*ind = 0;
		    } else {
			*m = m1;
			ipvt[*m] = *nmd + ni;
			ire[ni] = 1;
		    }
		} else {
		    ire[ni] = 0;
		}
	    }
	    w[ni] = s;
	}
 
    }
    if (*ind == 1) {
	*ind = info;
    }
}  

  int auxo01_(c__, ic, ci, cs, b, x, w, ire, ira, n, md, ind, 
	fun, iv)
doublereal *c__;
integer *ic;
doublereal *ci, *cs, *b, *x, *w;
integer *ire, *ira, *n, *md, *ind;
doublereal *fun;
integer *iv;
{
     
    integer c_dim1, c_offset, i__1, i__2;
    doublereal d__1;

     
    double pow_dd(), sqrt();

     
    extern   int ddif_();
    extern doublereal ddot_();
    static integer i__, ia, ij, ni;
    extern doublereal dlamch_();
    static doublereal xi;
    static integer nw;
    static doublereal gigant, cii, csi, eps;
    static integer nwi;
    static doublereal gig1;
     
    c_dim1 = *ic;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --ci;
    --cs;
    --b;
    --x;
    --w;
    --ire;

     
    if (*ind == 1) {
	*fun = 0.;
    }
    *iv = 0;
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);
    gigant = dlamch_("o", 1L);
    gig1 = sqrt(gigant);
    if (*ind == 1) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[i__] = 0.;
	}
	nw = *n * 3;
    } else {
	nw = 0;
    }
    if (*ira > 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    xi = x[i__];
	    ij = 0;
	    ia = (i__2 = ire[i__], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) );
	    if (*ira != 2) {
		cii = ci[i__];
		if (cii >= -gig1 && ia != 1) {
		    if (xi < cii - eps) {
			*iv = 1;
			if (*ind == 1) {
			    *fun = *fun + cii - xi;
			    ire[i__] = -2;
			    w[i__] = 1.;
			    ij = 1;
			} else {
			    return 0;
			}
		    } else if (*ind == 1) {
			ire[i__] = 0;
		    }
		}
	    }
	    if (*ira >= 2) {
		csi = cs[i__];
		if (csi <= gig1 && ij == 0 && ia != 1) {
		    if (xi > csi + eps) {
			*iv = 1;
			if (*ind == 1) {
			    *fun = *fun + xi - csi;
			    ire[i__] = 2;
			    w[i__] = -1.;
			} else {
			    return 0;
			}
		    } else if (*ind == 1) {
			ire[i__] = 0;
		    }
		}
	    }
 
	}
    }
    if (*md > 0) {
	i__1 = *md;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    nwi = nw + i__;
	    ni = *n + i__;
	    if (ire[ni] != 1) {
		w[nwi] = ddot_(n, &c__[i__ * c_dim1 + 1], &c__1, &x[1], &c__1)
			 - b[i__];
		if (w[nwi] > eps) {
		    *iv = 1;
		    if (*ind == 1) {
			ire[ni] = 2;
			ddif_(n, &c__[i__ * c_dim1 + 1], &c__1, &w[1], &c__1);
			*fun += w[nwi];
		    } else {
			return 0;
		    }
		} else if (*ind == 1) {
		    ire[ni] = 0;
		}
	    }
 
	}
    }
}  

  int bfgsd_(diag, n, nt, np, y, s, ys, condm, param, zero, 
	index)
doublereal *diag;
integer *n, *nt, *np;
doublereal *y, *s, *ys, *condm, *param, *zero;
integer *index;
{
     
    integer y_dim1, y_offset, s_dim1, s_offset, i__1;
    doublereal d__1, d__2;

     
    double log(), pow_dd();

     
    static doublereal dmin__, omeg, dmax__;
    static integer i__;
    static doublereal dd, dd1, ys1;
    static integer inp;
    static doublereal sds, sds1;

 
 
 
 


     
    --diag;
    --index;
    --ys;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;

     
    inp = index[*np];
    ys1 = (float)1. / ys[inp];
    sds = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = s[inp + i__ * s_dim1];
	sds += diag[i__] * (d__1 * d__1);
    }
    sds1 = (float)1. / sds;
    dmin__ = (float)1e25;
    dmax__ = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dd1 = *param * diag[i__];
	dd1 += *zero * (float)1e3;
 
	d__1 = y[inp + i__ * y_dim1];
 
	d__2 = diag[i__] * s[inp + i__ * s_dim1];
	dd = diag[i__] + ys1 * (d__1 * d__1) - sds1 * (d__2 * d__2);
	diag[i__] = dd;
 
	if (dd <= dd1) {
	    diag[i__] = dd1;
	}
 
	if (diag[i__] < dmin__) {
	    dmin__ = diag[i__];
	}
	if (diag[i__] > dmax__) {
	    dmax__ = diag[i__];
	}
 
    }
 
    if (*condm * dmin__ / dmax__ > 1.) {
	return 0;
    }
    omeg = log(*condm) / log(dmax__ / dmin__);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	diag[i__] = pow_dd(&diag[i__], &omeg);
    }
    return 0;
}  

  int calbx_(n, index, indic, nt, np, y, s, ys, z__, zs, x, 
	diag, bx)
integer *n, *index, *indic, *nt, *np;
doublereal *y, *s, *ys, *z__, *zs, *x, *diag, *bx;
{
     
    integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1, i__2;

     
    static integer i__, j, ii;
    static doublereal yx, zx;


 
 
 


     
    --bx;
    --diag;
    --x;
    --indic;
    --zs;
    z_dim1 = *nt;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    --ys;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;
    --index;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L100;
	}
	bx[i__] = diag[i__] * x[i__];
L100:
	;
    }

    i__1 = *np;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ii = index[i__];

	yx = 0.;
	zx = 0.;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    if (indic[j] > 0) {
		goto L120;
	    }
	    yx += y[ii + j * y_dim1] * x[j];
	    zx += z__[ii + j * z_dim1] * x[j];
L120:
	    ;
	}

	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    if (indic[j] > 0) {
		goto L130;
	    }
	    bx[j] = bx[j] + yx * y[ii + j * y_dim1] / ys[ii] - zx * z__[ii + 
		    j * z_dim1] / zs[ii];
L130:
	    ;
	}
 
    }

    return 0;
}  

  int calmaj_(dh, n, g1, sig, w, ir, mk, epsmc, nfac)
doublereal *dh;
integer *n;
doublereal *g1, *sig, *w;
integer *ir, *mk;
doublereal *epsmc;
integer *nfac;
{
     
    integer i__1, i__2;

     
    static integer nfac1, n2fac, i__, j, k, nnfac;
    extern   int majour_();

 
     
    --w;
    --g1;
    --dh;

     
    if (*nfac == *n) {
	goto L50;
    }
    nfac1 = *nfac + 1;
    nnfac = *n - *nfac;
    n2fac = *nfac * nfac1 / 2;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	w[i__] = g1[i__] * *sig;
    }
    k = n2fac;
    if (*nfac == 0) {
	goto L25;
    }
    i__1 = *nfac;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *n;
	for (i__ = nfac1; i__ <= i__2; ++i__) {
	    ++k;
	    dh[k] += g1[i__] * w[j];
 
	}
    }
L25:
    k = n2fac + *nfac * nnfac;
    i__2 = *n;
    for (j = nfac1; j <= i__2; ++j) {
	i__1 = *n;
	for (i__ = j; i__ <= i__1; ++i__) {
	    ++k;
	    dh[k] += g1[i__] * w[j];
 
	}
    }
L50:
    *ir = *nfac;
    if (*nfac == 0) {
	return 0;
    }
    majour_(&dh[1], &g1[1], &w[1], nfac, sig, ir, mk, epsmc);
    return 0;
}  

  int desr03_(z__, iz, r__, ir, g, w, d__, alfa, ipvt, n, ng, 
	ind, info, id, ro, io)
doublereal *z__;
integer *iz;
doublereal *r__;
integer *ir;
doublereal *g, *w, *d__, *alfa;
integer *ipvt, *n, *ng, *ind, *info, *id;
doublereal *ro;
integer *io;
{
     
    integer z_dim1, z_offset, r_dim1, r_offset, i__1, i__2;
    doublereal d__1;

     
    double pow_dd();

     
    extern doublereal ddot_(), dnrm2_();
    static integer i__, j, k, m;
    static doublereal s;
    extern   int dscal_();
    static doublereal x;
    extern   int anrs01_(), anrs02_(), dcopy_(), daxpy_();
    static integer m1, n1, m2, m3, mj;
    extern doublereal dlamch_();
    static doublereal eps;

     
    z_dim1 = *iz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --g;
    --w;
    --d__;
    --ipvt;

     
    *id = 0;
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);
    n1 = *n + 1;

 


    if (*ind >= 0) {
	*ro = 1.;
	if (*info == 0) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i__] = -ddot_(ng, &z__[(n1 - i__) * z_dim1 + 1], &c__1, &g[
			1], &c__1);
	    }
	} else if (*info == 1) {
	    x = -ddot_(ng, &z__[z_offset], &c__1, &g[1], &c__1);
	} else if (*info == 10) {
	    *info = 0;
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i__] = -w[i__];
	    }
	}
    }

 
 

    if (*ind == 0) {
	*id = 1;
	if (*info == 0) {
	    if (*alfa != 1.) {
		d__1 = 1. / *alfa;
		dscal_(n, &d__1, &w[1], &c__1);
	    }
	    anrs02_(&r__[r_offset], ir, &w[1], &d__[1], &ipvt[1], n, io);
	} else {
	    i__1 = *n - 1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i__] = 0.;
	    }
	    w[*n] = -1.;
	    anrs01_(&r__[r_offset], ir, n, &w[1], &d__[1], &c__2, io);
	    s = x * d__[*n];
	    if (s > 0.) {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[ipvt[i__]] = d__[i__];
		}
	    } else {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[ipvt[i__]] = -d__[i__];
		}
		s = -s;
	    }
	    if (*alfa != 1.) {
		*ro = s / *alfa;
	    } else {
		*ro = s;
	    }
	}

 

 

    } else if (*ind < -1 && *ind >= -(*n)) {
	m = -(*ind);
	m2 = m - 1;
	i__1 = m2;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__[i__] = -r__[i__ + m * r_dim1];
	}
	anrs01_(&r__[r_offset], ir, &m2, &d__[1], &d__[1], &c__2, io);
    } else if (*ind < -(*n)) {
	m = -(*ind) - *n;
	m1 = m + 1;
	s = r__[m + m1 * r_dim1];
	i__1 = m - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[i__] = s * r__[i__ + m * r_dim1] - r__[i__ + m1 * r_dim1];
	}
	if (m > 1) {
	    i__1 = m - 1;
	    anrs01_(&r__[r_offset], ir, &i__1, &w[1], &d__[1], &c__2, io);
	}
	d__[m] = -s;
	m2 = m;

 


    } else if (*ind > 0 && *ind < *n) {
	k = 0;
	m = *n - *ind;
	if (*info == 0) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[*n + i__] = w[ipvt[i__]];
	    }
	}

 

	i__1 = m;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__[i__] = 0.;
	}
	i__1 = *ind;
	for (j = 1; j <= i__1; ++j) {
	    mj = m + j;
	    anrs01_(&r__[r_offset], ir, &m, &r__[mj * r_dim1 + 1], &w[1], &
		    c__2, io);
	    if (*info == 0) {
		s = ddot_(&m, &w[1], &c__1, &w[n1], &c__1) - w[mj + *n];
	    } else {
		i__ = 1;
		if (*n != ipvt[i__]) {
L5010:
		    ++i__;
		    if (*n != ipvt[i__]) {
			goto L5010;
		    }
		}
		if (i__ == mj) {
		    s = -x;
		} else if (i__ <= m) {
		    s = w[i__] * x;
		} else {
		    s = 0.;
		}
	    }
	    if ((( s ) >= 0 ? ( s ) : -( s ))  > eps) {
		k = 1;
		daxpy_(&m, &s, &w[1], &c__1, &d__[1], &c__1);
		d__[mj] = -s;
	    }
 
	}

 
 

	if (k == 0) {
	    *id = 1;
	    if (*info == 0) {
		i__1 = *n;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[ipvt[i__]] = w[*n + i__];
		}
		if (*alfa != 1.) {
		    d__1 = 1 / *alfa;
		    dscal_(n, &d__1, &w[1], &c__1);
		}
		anrs02_(&r__[r_offset], ir, &w[1], &d__[1], &ipvt[1], &m, io);
		i__1 = *n;
		for (i__ = m + 1; i__ <= i__1; ++i__) {
 
		    w[ipvt[i__]] = 0.;
		}
	    } else {
		d__[m] = -1.;
		i__1 = m - 1;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    d__[i__] = 0.;
		}
		anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io);
		i__1 = *n;
		for (i__ = m + 1; i__ <= i__1; ++i__) {
 
		    d__[i__] = 0.;
		}
	    }
	}
	if (k == 1 || *info == 1) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[ipvt[i__]] = d__[i__];
	    }
	}

 

    } else if (*ind > *n && *ind <= *n << 1) {
	m = (*n << 1) - *ind;
	m3 = m + 1;
	if (m > 0) {
	    m1 = *n - m3;
	    i__1 = m;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__[i__] = ddot_(&m1, &r__[i__ + m3 * r_dim1], ir, &r__[m3 + *
			n * r_dim1], &c__1) - r__[i__ + *n * r_dim1];
	    }
	    anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io);
	}
	i__1 = *n - 1;
	for (i__ = m3; i__ <= i__1; ++i__) {
 
	    d__[i__] = -r__[i__ + *n * r_dim1];
	}
	d__[*n] = 1.;
	if (x < 0.) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__[i__] = -d__[i__];
	    }
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[ipvt[i__]] = d__[i__];
	}
    } else if (*ind > *n << 1) {
	m2 = *ind - (*n << 1);
	m = *n - m2;
	m3 = m + 1;
	i__1 = m - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    d__[i__] = -ddot_(&m2, &r__[i__ + m3 * r_dim1], ir, &r__[m + m3 * 
		    r_dim1], ir);
	}
	s = dnrm2_(&m2, &r__[m + m3 * r_dim1], ir);
	d__[m] = -s * s;
	anrs01_(&r__[r_offset], ir, &m, &d__[1], &d__[1], &c__2, io);
	i__1 = *n;
	for (i__ = m3; i__ <= i__1; ++i__) {
 
	    d__[i__] = -r__[m + i__ * r_dim1];
	}
	s = d__[m] * x;
	if (s < 0.) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__[i__] = -d__[i__];
	    }
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[ipvt[i__]] = d__[i__];
	}
    }
    if (*ind < 0) {

 

	if (*n > 1) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i__] = 0.;
	    }
	    if (*ind < -1) {
		i__1 = m2;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[ipvt[i__]] = d__[i__];
		}
		w[ipvt[m2 + 1]] = 1.;
	    }
	}
    }

 

    if (*ind == *n && *info == 1) {
	if ((( x ) >= 0 ? ( x ) : -( x ))  > eps) {
	    i__1 = *ng;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__[i__] = x * z__[i__ + z_dim1];
	    }
	} else {
	    *id = 1;
	    i__1 = *ng;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		d__[i__] = 0.;
	    }
	}
    } else if (*ind == -1) {
	dcopy_(ng, &z__[(n1 - ipvt[1]) * z_dim1 + 1], &c__1, &d__[1], &c__1);
    } else {
	if (*ind == *n) {
	    s = dnrm2_(n, &w[1], &c__1);
	    if (s <= eps) {
		*id = 1;
		i__1 = *ng;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    d__[i__] = 0.;
		}
	    }
	}
	if (*ind != *n || *ind == *n && *id == 0) {
	    i__1 = *ng;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		i__2 = -(*iz);
		d__[i__] = ddot_(n, &z__[i__ + z_dim1], &i__2, &w[1], &c__1);
	    }
	}
    }

 

 

    if (*ind < 0 || *id == 1 && *info == 1 && *ind > 0) {
	s = ddot_(ng, &d__[1], &c__1, &g[1], &c__1);
	if (*id == 1) {
	    if (s > 0.) {
		i__2 = *ng;
		for (i__ = 1; i__ <= i__2; ++i__) {
 
		    d__[i__] = -d__[i__];
		}
	    } else {
		s = -s;
	    }
	    if (*alfa != 1.) {
		*ro = s / *alfa;
	    } else {
		*ro = s;
	    }
	} else if (s > 0.) {
	    i__2 = *ng;
	    for (i__ = 1; i__ <= i__2; ++i__) {
 
		d__[i__] = -d__[i__];
	    }
	}
    }
}  

  int dimp03_(x, w, ire, ipvt, s, i1, i2, i3, i4, i5, i6, i7, 
	i8, i9, ind, imp, io, iter)
doublereal *x, *w;
integer *ire, *ipvt;
doublereal *s;
integer *i1, *i2, *i3, *i4, *i5, *i6, *i7, *i8, *i9, *ind, *imp, *io, *iter;
{
     
    static char fmt_5000[] = "(//,10x,a,(t31,sp,e22.16))";
    static char fmt_4000[] = "(////,80(\002-\002),///,10x,\002ITERATION: \002,i4)";
    static char fmt_3000[] = "(///,10x,a,i4)";
    static char fmt_8000[] = "(//,10x,a,//,(10x,11(2x,i4),/))";
    static char fmt_1000[] = "(////,80(\002*\002),///,10x,a,2(/,10x,a),i5)";
    static char fmt_7000[] = "(/,10x,a,e22.16)";
    static char fmt_9000[] = "(/,10x,a,/,(10x,4(2x,e14.8)))";
    static char fmt_2000[] = "(////,80(\002*\002),///,10x,a,/,10x,a,i5)";
    static char fmt_6000[] = "(/,10x,a,t41,e22.16)";

     
    integer i__1;

     
      int s_copy();
    integer s_wsfe(), do_fio(), e_wsfe();

     
    extern doublereal dnrm0_();
    static integer i__, j;
    static doublereal s1;
    static integer ii2, ii7;
    static char car[30];

     
    static cilist io___1968 = { 0, 0, 0, fmt_5000, 0 };
    static cilist io___1970 = { 0, 0, 0, fmt_4000, 0 };
    static cilist io___1972 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1973 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1975 = { 0, 0, 0, fmt_8000, 0 };
    static cilist io___1976 = { 0, 0, 0, fmt_8000, 0 };
    static cilist io___1977 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1978 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1979 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1980 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1982 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1983 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1984 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1985 = { 0, 0, 0, fmt_5000, 0 };
    static cilist io___1986 = { 0, 0, 0, fmt_7000, 0 };
    static cilist io___1987 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1988 = { 0, 0, 0, fmt_8000, 0 };
    static cilist io___1989 = { 0, 0, 0, fmt_9000, 0 };
    static cilist io___1990 = { 0, 0, 0, fmt_7000, 0 };
    static cilist io___1991 = { 0, 6, 0, fmt_1000, 0 };
    static cilist io___1992 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1993 = { 0, 0, 0, fmt_2000, 0 };
    static cilist io___1994 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1995 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1996 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1997 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___1998 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___1999 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2000 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___2002 = { 0, 0, 0, fmt_6000, 0 };
    static cilist io___2003 = { 0, 0, 0, fmt_6000, 0 };
    static cilist io___2004 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___2005 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2006 = { 0, 0, 0, fmt_3000, 0 };

     
    --ipvt;
    --ire;
    --w;
    --x;

     
    s_copy(car, "END OF OPTR03.", 30L, 14L);
    if (*ind == 2) {
	if (*imp >= 10) {
	    io___1968.ciunit = *io;
	    s_wsfe(&io___1968);
	    do_fio(&c__1, "POINT COMPUTED: ", 16L);
	    i__1 = *i1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
	    }
	    e_wsfe();
	}
	io___1970.ciunit = *io;
	s_wsfe(&io___1970);
	do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	e_wsfe();
	if (*i2 != 0) {
	    ii2 = *i2;
	    if (*i2 > *i1) {
		ii2 = *i2 + *i9;
	    }
	    io___1972.ciunit = *io;
	    s_wsfe(&io___1972);
	    do_fio(&c__1, "DELETED CONSTRAINT: ", 20L);
	    do_fio(&c__1, (char *)&ii2, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	io___1973.ciunit = *io;
	s_wsfe(&io___1973);
	do_fio(&c__1, "NUMBER OF ACTIVE CONSTRAINTS:", 29L);
	do_fio(&c__1, (char *)&(*i3), (ftnlen)sizeof(integer));
	e_wsfe();
	i__1 = *i9;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    ipvt[i__] += *i1;
	}
	i__1 = *i3;
	for (i__ = *i9 + 1; i__ <= i__1; ++i__) {
	    j = ipvt[i__];
	    if (j > *i1) {
		ipvt[i__] = j + *i8;
	    }
 
	}
	io___1975.ciunit = *io;
	s_wsfe(&io___1975);
	do_fio(&c__1, "ACTIVE CONSTRAINTS:", 19L);
	i__1 = *i3;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_fio(&c__1, (char *)&ipvt[i__], (ftnlen)sizeof(integer));
	}
	e_wsfe();
	i__1 = *i9;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    ipvt[i__] -= *i1;
	}
	i__1 = *i3;
	for (i__ = *i9 + 1; i__ <= i__1; ++i__) {
	    j = ipvt[i__];
	    if (j > *i1) {
		ipvt[i__] = j - *i8;
	    }
 
	}
	if (*i4 > 0) {
	    io___1976.ciunit = *io;
	    s_wsfe(&io___1976);
	    do_fio(&c__1, "-CONSTRAINTS ASSOCIATED TO THE OBJECTIVE FUNCTION:"
		    , 50L);
	    i__1 = *i4;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&ire[i__], (ftnlen)sizeof(integer));
	    }
	    e_wsfe();
	}
	if (*i5 == 1) {
	    io___1977.ciunit = *io;
	    s_wsfe(&io___1977);
	    do_fio(&c__1, "A DESCENT DIRECTION OF POSITIVE CURVATURE HAS BEEN COMPUTED.", 60L);
	    e_wsfe();
	} else if (*i5 == 0) {
	    io___1978.ciunit = *io;
	    s_wsfe(&io___1978);
	    do_fio(&c__1, "A DESCENT DIRECTION OF NULL CURVATURE HAS BEEN COMPUTED.", 56L);
	    e_wsfe();
	} else {
	    io___1979.ciunit = *io;
	    s_wsfe(&io___1979);
	    do_fio(&c__1, "A DESCENT DIRECTION OF NEGATIVE CURVATURE HAS BEEN COMPUTED.", 60L);
	    e_wsfe();
	}
	if (*i6 != 0) {
	    io___1980.ciunit = *io;
	    s_wsfe(&io___1980);
	    do_fio(&c__1, "A DEGENERATED POINT HAS BEEN COMPUTED.", 38L);
	    e_wsfe();
	}
	if (*i7 != 0) {
	    ii7 = *i7;
	    if (ii7 > *i1) {
		ii7 += *i9;
	    }
	    io___1982.ciunit = *io;
	    s_wsfe(&io___1982);
	    do_fio(&c__1, "ADDED CONSTRAINT: ", 18L);
	    do_fio(&c__1, (char *)&ii7, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    } else if (*ind == 0) {
	io___1983.ciunit = *io;
	s_wsfe(&io___1983);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "A LOCAL MINIMUM HAS BEEN FOUND.", 31L);
	e_wsfe();
	if (*imp >= 8) {
	    io___1984.ciunit = *io;
	    s_wsfe(&io___1984);
	    do_fio(&c__1, "NUMBER OF ITERATIONS: ", 22L);
	    do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	    e_wsfe();
	    io___1985.ciunit = *io;
	    s_wsfe(&io___1985);
	    do_fio(&c__1, "POINT COMPUTED: ", 16L);
	    i__1 = *i1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
	    }
	    e_wsfe();
	    io___1986.ciunit = *io;
	    s_wsfe(&io___1986);
	    do_fio(&c__1, "NORM OF THE KUHN-TUCKER VECTOR: ", 32L);
	    do_fio(&c__1, (char *)&(*s), (ftnlen)sizeof(doublereal));
	    e_wsfe();
	    io___1987.ciunit = *io;
	    s_wsfe(&io___1987);
	    do_fio(&c__1, "NUMBER OF ACTIVE CONSTRAINTS:", 29L);
	    do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer));
	    e_wsfe();
	    i__1 = *i9;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		ipvt[i__] += *i1;
	    }
	    i__1 = *i2;
	    for (i__ = *i9 + 1; i__ <= i__1; ++i__) {
		j = ipvt[i__];
		if (j > *i1) {
		    ipvt[i__] = j + *i8;
		}
 
	    }
	    io___1988.ciunit = *io;
	    s_wsfe(&io___1988);
	    do_fio(&c__1, "ACTIVE CONSTRAINTS:", 19L);
	    i__1 = *i2;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&ipvt[i__], (ftnlen)sizeof(integer));
	    }
	    e_wsfe();
	    i__1 = *i9;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		ipvt[i__] -= *i1;
	    }
	    i__1 = *i2;
	    for (i__ = *i9 + 1; i__ <= i__1; ++i__) {
		j = ipvt[i__];
		if (j > *i1) {
		    ipvt[i__] = j - *i8;
		}
 
	    }
	    io___1989.ciunit = *io;
	    s_wsfe(&io___1989);
	    do_fio(&c__1, "LAGRANGE MULTIPLIERS:", 21L);
	    i__1 = *i3 + *i2 - 1;
	    for (i__ = *i3; i__ <= i__1; ++i__) {
		do_fio(&c__1, (char *)&w[i__], (ftnlen)sizeof(doublereal));
	    }
	    e_wsfe();
	    if (*i4 != 0) {
		io___1990.ciunit = *io;
		s_wsfe(&io___1990);
		do_fio(&c__1, "OBJECTIVE FUNCTION: ", 20L);
		do_fio(&c__1, (char *)&w[*i4], (ftnlen)sizeof(doublereal));
		e_wsfe();
	    }
	}
    } else if (*ind == -4) {
	if (*io <= 0) {
	    s_wsfe(&io___1991);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "INVALID NUMBER FOR THE OUTPUT CHANEL NUMBER.", 44L)
		    ;
	    e_wsfe();
	} else if (*imp >= 7) {
	    io___1992.ciunit = *io;
	    s_wsfe(&io___1992);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "INVALID INTEGER VARIABLES.", 26L);
	    e_wsfe();
	}
    } else if (*ind == -24) {
	io___1993.ciunit = *io;
	s_wsfe(&io___1993);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "CI(I).GT.CS(I) FOR I= ", 22L);
	do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
	e_wsfe();
    } else if (*ind == -34) {
	io___1994.ciunit = *io;
	s_wsfe(&io___1994);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L);
	e_wsfe();
    } else if (*ind < -10) {
	io___1995.ciunit = *io;
	s_wsfe(&io___1995);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "OPTR01 HAS NOT FOUND A FEASIBLE POINT.IND OF", 44L);
	do_fio(&c__1, "OPTR01=", 7L);
	i__1 = *ind + 10;
	do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
	e_wsfe();
    } else if (*ind == -1) {
	io___1996.ciunit = *io;
	s_wsfe(&io___1996);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "PROBLEM UNBOUNDED FROM BELOW", 28L);
	e_wsfe();
    } else if (*ind == -2) {
	io___1997.ciunit = *io;
	s_wsfe(&io___1997);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "A DEGENERATED POINT CYCLING HAS BEEN FOUND.", 43L);
	e_wsfe();
	if (*imp >= 8) {
	    io___1998.ciunit = *io;
	    s_wsfe(&io___1998);
	    do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L);
	    do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    } else if (*ind == -3) {
	io___1999.ciunit = *io;
	s_wsfe(&io___1999);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "THE DISTANCE BETWEEN THE POINTS OF TWO CONSECUTIVE ITERATIONS ", 62L);
	do_fio(&c__1, "IS \"TOO BIG\".", 13L);
	e_wsfe();
	io___2000.ciunit = *io;
	s_wsfe(&io___2000);
	do_fio(&c__1, "PROBABLY PROBLEM UNBOUNDED FROM BELOW.", 38L);
	e_wsfe();
	if (*imp >= 8) {
	    s1 = dnrm0_(i1, &x[1], &c__1);
	    io___2002.ciunit = *io;
	    s_wsfe(&io___2002);
	    do_fio(&c__1, "-NORM OF THE POINT COMPUTED:", 28L);
	    do_fio(&c__1, (char *)&s1, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	    io___2003.ciunit = *io;
	    s_wsfe(&io___2003);
	    do_fio(&c__1, "-OBJECTIVE FUNCTION:", 20L);
	    do_fio(&c__1, (char *)&w[*i2], (ftnlen)sizeof(doublereal));
	    e_wsfe();
	    io___2004.ciunit = *io;
	    s_wsfe(&io___2004);
	    do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L);
	    do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    } else if (*ind == 1) {
	io___2005.ciunit = *io;
	s_wsfe(&io___2005);
	do_fio(&c__1, car, 30L);
	do_fio(&c__1, "THE LIMIT FOR THE ITERATION NUMBER HAS BEEN PASSED.", 
		51L);
	e_wsfe();
	if (*imp >= 8) {
	    io___2006.ciunit = *io;
	    s_wsfe(&io___2006);
	    do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L);
	    do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    }
}  

  int dipvtf_(r__, ir, ipvt, n, i1, i2)
doublereal *r__;
integer *ir, *ipvt, *n, *i1, *i2;
{
     
    integer r_dim1, r_offset;

     
    static integer i__;
    extern   int dswap_();

     
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --ipvt;

     
    if (*i1 == *i2) {
	return 0;
    }
    dswap_(n, &r__[*i1 * r_dim1 + 1], &c__1, &r__[*i2 * r_dim1 + 1], &c__1);
    i__ = ipvt[*i1];
    ipvt[*i1] = ipvt[*i2];
    ipvt[*i2] = i__;
}  

doublereal dnrm0_(n, x, incx)
integer *n;
doublereal *x;
integer *incx;
{
     
    doublereal ret_val, d__1;

     
    static integer i__;
    extern integer idamax_();


 

 

     
    --x;

     
    ret_val = 0.;
    if (*n < 1) {
	return ret_val;
    }
    i__ = idamax_(n, &x[1], incx);
    ret_val = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    return ret_val;
}  

  int dogleg_(n, r__, lr, diag, qtb, delta, x, wa1, wa2)
integer *n;
doublereal *r__;
integer *lr;
doublereal *diag, *qtb, *delta, *x, *wa1, *wa2;
{
     

    static doublereal one = 1.;
    static doublereal zero = 0.;

     
    integer i__1, i__2;
    doublereal d__1, d__2, d__3, d__4;

     
    double sqrt();

     
    static doublereal temp;
    static integer i__, j, k, l;
    static doublereal alpha, bnorm;
    extern doublereal enorm_();
    static doublereal gnorm, qnorm;
    static integer jj;
    extern doublereal dlamch_();
    static doublereal epsmch, sgnorm;
    static integer jp1;
    static doublereal sum;
     
    --wa2;
    --wa1;
    --x;
    --qtb;
    --diag;
    --r__;

     

 

    epsmch = dlamch_("p", 1L);

 

    jj = *n * (*n + 1) / 2 + 1;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	j = *n - k + 1;
	jp1 = j + 1;
	jj -= k;
	l = jj + 1;
	sum = zero;
	if (*n < jp1) {
	    goto L20;
	}
	i__2 = *n;
	for (i__ = jp1; i__ <= i__2; ++i__) {
	    sum += r__[l] * x[i__];
	    ++l;
 
	}
L20:
	temp = r__[jj];
	if (temp != zero) {
	    goto L40;
	}
	l = j;
	i__2 = j;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    d__2 = temp, d__3 = (d__1 = r__[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    temp = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
	    l = l + *n - i__;
 
	}
	temp = epsmch * temp;
	if (temp == zero) {
	    temp = epsmch;
	}
L40:
	x[j] = (qtb[j] - sum) / temp;
 
    }

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa1[j] = zero;
	wa2[j] = diag[j] * x[j];
 
    }
    qnorm = enorm_(n, &wa2[1]);
    if (qnorm <= *delta) {
	goto L140;
    }

 
 

    l = 1;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	temp = qtb[j];
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    wa1[i__] += r__[l] * temp;
	    ++l;
 
	}
	wa1[j] /= diag[j];
 
    }

 
 

    gnorm = enorm_(n, &wa1[1]);
    sgnorm = zero;
    alpha = *delta / qnorm;
    if (gnorm == zero) {
	goto L120;
    }

 
 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa1[j] = wa1[j] / gnorm / diag[j];
 
    }
    l = 1;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	sum = zero;
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    sum += r__[l] * wa1[i__];
	    ++l;
 
	}
	wa2[j] = sum;
 
    }
    temp = enorm_(n, &wa2[1]);
    sgnorm = gnorm / temp / temp;

 

    alpha = zero;
    if (sgnorm >= *delta) {
	goto L120;
    }

 
 
 

    bnorm = enorm_(n, &qtb[1]);
    temp = bnorm / gnorm * (bnorm / qnorm) * (sgnorm / *delta);
 
    d__1 = sgnorm / *delta;
 
    d__2 = temp - *delta / qnorm;
 
    d__3 = *delta / qnorm;
 
    d__4 = sgnorm / *delta;
    temp = temp - *delta / qnorm * (d__1 * d__1) + sqrt(d__2 * d__2 + (one - 
	    d__3 * d__3) * (one - d__4 * d__4));
 
    d__1 = sgnorm / *delta;
    alpha = *delta / qnorm * (one - d__1 * d__1) / temp;
L120:

 
 

    temp = (one - alpha) * (( sgnorm ) <= ( *delta ) ? ( sgnorm ) : ( *delta )) ;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	x[j] = temp * wa1[j] + alpha * x[j];
 
    }
L140:
    return 0;

 

}  

doublereal enorm_(n, x)
integer *n;
doublereal *x;
{
     

    static doublereal one = 1.;
    static doublereal zero = 0.;
    static doublereal rdwarf = 3.834e-20;
    static doublereal rgiant = 1.304e19;

     
    integer i__1;
    doublereal ret_val, d__1;

     
    double sqrt();

     
    static doublereal xabs, x1max, x3max;
    static integer i__;
    static doublereal s1, s2, s3, agiant, floatn;
     
    --x;

     
    s1 = zero;
    s2 = zero;
    s3 = zero;
    x1max = zero;
    x3max = zero;
    floatn = (doublereal) (*n);
    agiant = rgiant / floatn;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xabs = (d__1 = x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (xabs > rdwarf && xabs < agiant) {
	    goto L70;
	}
	if (xabs <= rdwarf) {
	    goto L30;
	}

 

	if (xabs <= x1max) {
	    goto L10;
	}
 
	d__1 = x1max / xabs;
	s1 = one + s1 * (d__1 * d__1);
	x1max = xabs;
	goto L20;
L10:
 
	d__1 = xabs / x1max;
	s1 += d__1 * d__1;
L20:
	goto L60;
L30:

 

	if (xabs <= x3max) {
	    goto L40;
	}
 
	d__1 = x3max / xabs;
	s3 = one + s3 * (d__1 * d__1);
	x3max = xabs;
	goto L50;
L40:
	if (xabs != zero) {
 
	    d__1 = xabs / x3max;
	    s3 += d__1 * d__1;
	}
L50:
L60:
	goto L80;
L70:

 

 
	d__1 = xabs;
	s2 += d__1 * d__1;
L80:
 
	;
    }

 

    if (s1 == zero) {
	goto L100;
    }
    ret_val = x1max * sqrt(s1 + s2 / x1max / x1max);
    goto L130;
L100:
    if (s2 == zero) {
	goto L110;
    }
    if (s2 >= x3max) {
	ret_val = sqrt(s2 * (one + x3max / s2 * (x3max * s3)));
    }
    if (s2 < x3max) {
	ret_val = sqrt(x3max * (s2 / x3max + x3max * s3));
    }
    goto L120;
L110:
    ret_val = x3max * sqrt(s3);
L120:
L130:
    return ret_val;

 

}  

  int fdjac1_(fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, 
	epsfcn, wa1, wa2)
  int (*fcn) ();
integer *n;
doublereal *x, *fvec, *fjac;
integer *ldfjac, *iflag, *ml, *mu;
doublereal *epsfcn, *wa1, *wa2;
{
     

    static doublereal zero = 0.;

     
    integer fjac_dim1, fjac_offset, i__1, i__2, i__3, i__4;
    doublereal d__1;

     
    double sqrt();

     
    static doublereal temp;
    static integer msum;
    static doublereal h__;
    static integer i__, j, k;
    extern doublereal dlamch_();
    static doublereal epsmch, eps;
     
    --wa2;
    --wa1;
    --fvec;
    --x;
    fjac_dim1 = *ldfjac;
    fjac_offset = fjac_dim1 + 1;
    fjac -= fjac_offset;

     

 

    epsmch = dlamch_("p", 1L);

    eps = sqrt(((( *epsfcn ) >= ( epsmch ) ? ( *epsfcn ) : ( epsmch )) ));
    msum = *ml + *mu + 1;
    if (msum < *n) {
	goto L40;
    }

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	temp = x[j];
	h__ = eps * (( temp ) >= 0 ? ( temp ) : -( temp )) ;
	if (h__ == zero) {
	    h__ = eps;
	}
	x[j] = temp + h__;
	(*fcn)(n, &x[1], &wa1[1], iflag);
	if (*iflag < 0) {
	    goto L30;
	}
	x[j] = temp;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    fjac[i__ + j * fjac_dim1] = (wa1[i__] - fvec[i__]) / h__;
 
	}
 
    }
L30:
    goto L110;
L40:

 

    i__1 = msum;
    for (k = 1; k <= i__1; ++k) {
	i__2 = *n;
	i__3 = msum;
	for (j = k; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) {
	    wa2[j] = x[j];
	    h__ = eps * (d__1 = wa2[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (h__ == zero) {
		h__ = eps;
	    }
	    x[j] = wa2[j] + h__;
 
	}
	(*fcn)(n, &x[1], &wa1[1], iflag);
	if (*iflag < 0) {
	    goto L100;
	}
	i__3 = *n;
	i__2 = msum;
	for (j = k; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
	    x[j] = wa2[j];
	    h__ = eps * (d__1 = wa2[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (h__ == zero) {
		h__ = eps;
	    }
	    i__4 = *n;
	    for (i__ = 1; i__ <= i__4; ++i__) {
		fjac[i__ + j * fjac_dim1] = zero;
		if (i__ >= j - *mu && i__ <= j + *ml) {
		    fjac[i__ + j * fjac_dim1] = (wa1[i__] - fvec[i__]) / h__;
		}
 
	    }
 
	}
 
    }
L100:
L110:
    return 0;

 

}  

  int fdjac2_(fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn, 
	wa)
  int (*fcn) ();
integer *m, *n;
doublereal *x, *fvec, *fjac;
integer *ldfjac, *iflag;
doublereal *epsfcn, *wa;
{
     

    static doublereal zero = 0.;

     
    integer fjac_dim1, fjac_offset, i__1, i__2;

     
    double sqrt();

     
    static doublereal temp, h__;
    static integer i__, j;
    extern doublereal dlamch_();
    static doublereal epsmch, eps;
     
    --wa;
    --fvec;
    --x;
    fjac_dim1 = *ldfjac;
    fjac_offset = fjac_dim1 + 1;
    fjac -= fjac_offset;

     

 

    epsmch = dlamch_("p", 1L);

    eps = sqrt(((( *epsfcn ) >= ( epsmch ) ? ( *epsfcn ) : ( epsmch )) ));
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	temp = x[j];
	h__ = eps * (( temp ) >= 0 ? ( temp ) : -( temp )) ;
	if (h__ == zero) {
	    h__ = eps;
	}
	x[j] = temp + h__;
	(*fcn)(m, n, &x[1], &wa[1], iflag);
	if (*iflag < 0) {
	    goto L30;
	}
	x[j] = temp;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    fjac[i__ + j * fjac_dim1] = (wa[i__] - fvec[i__]) / h__;
 
	}
 
    }
L30:
    return 0;

 

}  

  int ffinf1_(n, nv, jc, xpr, p, s)
integer *n, *nv, *jc;
doublereal *xpr, *p, *s;
{
     
    integer i__1, i__2;

     
    static integer i__, j, k;
    static doublereal ps;
    static integer nij;


 
 

     
    --s;
    --xpr;
    --jc;
    --p;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ps = 0.;
	i__2 = *nv;
	for (k = 1; k <= i__2; ++k) {
	    j = jc[k] - 1;
	    if (j == 0) {
		goto L910;
	    }
	    nij = (j - 1) * *n + i__;
	    ps += xpr[k] * p[nij];
L910:
	    ;
	}
 
	s[i__] = ps;
    }
    return 0;
}  

  int fmulb1_(n, h__, x, hx, tabaux, nmisaj, prosca, izs, rzs, 
	dzs)
integer *n;
doublereal *h__, *x, *hx, *tabaux;
integer *nmisaj;
  int (*prosca) ();
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    integer i__1;

     
    static integer ptnu, k;
    static doublereal gamma, sigma;
    static integer compt, is, iu;
    static doublereal mu, nu, sscalx, uscalx;
    static integer memsup;
    static doublereal eta;


 
 

 
     
    --tabaux;
    --hx;
    --x;
    --h__;
    --izs;
    --rzs;
    --dzs;

     
    memsup = (*n << 1) + 2;
 
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	hx[k] = x[k];
 
    }

    if (*nmisaj == 0) {
	return 0;
    } else {
	ptnu = 1;
	compt = 1;
    }

L2000:
    iu = ptnu + 1;
    is = iu + *n;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	tabaux[k] = h__[iu + k];
 
    }
    (*prosca)(n, &tabaux[1], &x[1], &uscalx, &izs[1], &rzs[1], &dzs[1]);
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	tabaux[k] = h__[is + k];
 
    }
    (*prosca)(n, &tabaux[1], &x[1], &sscalx, &izs[1], &rzs[1], &dzs[1]);
    nu = h__[ptnu];
    eta = h__[ptnu + 1];
 
    if (compt == 1) {
	gamma = eta / nu;
	i__1 = *n;
	for (k = 1; k <= i__1; ++k) {
	    hx[k] = gamma * hx[k];
 
	}
	mu = sscalx / nu;
	sigma = -(sscalx * 2. / eta) + uscalx / nu;
    } else {
	mu = sscalx / eta;
	sigma = -(nu / eta + 1.) * mu + uscalx / eta;
    }

    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	hx[k] = hx[k] - mu * h__[iu + k] - sigma * h__[is + k];
 
    }

    ++compt;
    if (compt <= *nmisaj) {
	ptnu += memsup;
	goto L2000;
    } else {
	return 0;
    }
}  

  int fmuls1_(n, h__, x, hx)
integer *n;
doublereal *h__, *x, *hx;
{
     
    integer i__1, i__2;

     
    static integer j, k, kj, km1;
    static doublereal aux1;


 
 
 
 
 


 
 

     
    --hx;
    --x;
    --h__;

     
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
 
	aux1 = 0.;
 
	kj = k;
	km1 = k - 1;
 
	if (km1 >= 1) {
	    i__2 = km1;
	    for (j = 1; j <= i__2; ++j) {
		aux1 += h__[kj] * x[j];
		kj += *n - j;
 
	    }
	}
 
	i__2 = *n;
	for (j = k; j <= i__2; ++j) {
	    aux1 += h__[kj] * x[j];
	    ++kj;
 
	}

	hx[k] = aux1;
 
    }

    return 0;
}  

  int fpq2_(inout, x, cx, fx, gx, d__, sthalf, penlty, iyflag, 
	y, cy, fy, gy, z__, cz, fz, gz, gg, hh, s)
integer *inout;
doublereal *x, *cx, *fx, *gx, *d__, *sthalf, *penlty;
integer *iyflag;
doublereal *y, *cy, *fy, *gy, *z__, *cz, *fz, *gz, *gg, *hh, *s;
{
     

    static doublereal zero = 0.;
    static doublereal half = .5;

     
    doublereal d__1, d__2;

     
    double d_sign();

     
    static doublereal absd, p, denom, absgx, smallh, dlower, dupper, gyplus, 
	    xminsy;

    absd = (( *d__ ) >= 0 ? ( *d__ ) : -( *d__ )) ;
    if (*inout == 0) {
	*iyflag = 0;
	*gg = zero;
	*hh = zero;
	*s = absd;
	if (*sthalf <= zero || *sthalf >= half) {
	    *sthalf = half * half;
	}
	if (*penlty <= zero) {
	    *penlty = half + half;
	}
	if (*gx != zero) {
	    *d__ = -d_sign(&absd, gx);
	}
	*inout = 1;
    } else {
	if (*cz > zero || *fz >= *fx) {
	    *inout = 3;
	    if (*iyflag == 0) {
 
		*gg = (*gz - *gx) / *d__;
		*hh = *gg;
 
		*s = *sthalf / absd;
		*iyflag = 1;
	    } else {
		*hh = (*gz - *gy) / (*d__ - (*y - *x));
	    }
	    *y = *z__;
	    *cy = *cz;
	    *fy = *fz;
	    *gy = *gz;
	} else {
	    if (*gx * *gz < zero) {
		*inout = 2;
		*hh = *gg;
		if (*iyflag == 0) {
		    *gg = (*gz - *gx) / *d__;
		    *s = *sthalf / absd;
		    *iyflag = 1;
		} else {
		    *gg = (*gz - *gy) / (*d__ - (*y - *x));
		}
		*y = *x;
		*cy = *cx;
		*fy = *fx;
		*gy = *gx;
	    } else {
		*inout = 1;
		*gg = (*gz - *gx) / *d__;
	    }
	    *x = *z__;
	    *cx = *cz;
	    *fx = *fz;
	    *gx = *gz;
	}
	if (*iyflag == 0) {
	    dlower = *s;
	    dupper = absd / *sthalf;
	    xminsy = -(*d__);
	} else {
	    xminsy = *x - *y;
	    smallh = (( zero ) <= ( *hh ) ? ( zero ) : ( *hh ))  * xminsy * half;
	    gyplus = *gy + smallh;
 
	    p = *fx - *fy - gyplus * xminsy;
	    denom = (d__1 = gyplus + smallh - *gx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
 
 
 
	    if (p >= zero) {
		goto L500;
	    }
	    p = zero;
	    *s = *sthalf / (( xminsy ) >= 0 ? ( xminsy ) : -( xminsy )) ;
L500:
	    dlower = *s * xminsy * xminsy;
	    dupper = (( xminsy ) >= 0 ? ( xminsy ) : -( xminsy ))  - dlower;
	    if ((( p ) >= 0 ? ( p ) : -( p ))  < denom * dupper) {
 
		d__1 = dlower, d__2 = p / denom;
		dupper = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	    }
	}
	absgx = (( *gx ) >= 0 ? ( *gx ) : -( *gx )) ;
	absd = dupper;
	if (absgx < *gg * dupper) {
 
	    d__1 = dlower, d__2 = absgx / *gg;
	    absd = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	}
	*d__ = -d_sign(&absd, &xminsy);
    }
    *z__ = *x + *d__;
    return 0;
}  

  int fprf2_(iflag, ntot, nv, io, zero, s2, eps, al, imp, u, 
	eta, mm1, jc, ic, r__, a, e, rr, xpr, y, w1, w2)
integer *iflag, *ntot, *nv, *io;
doublereal *zero, *s2, *eps, *al;
integer *imp;
doublereal *u, *eta;
integer *mm1, *jc, *ic;
doublereal *r__, *a, *e, *rr, *xpr, *y, *w1, *w2;
{
     
    static char fmt_1001[] = "(\002     epsilon smaller than a\002)";
    static char fmt_1003[] = "(\002 a=\002,10d10.3,/(6x,10d10.3))";
    static char fmt_1004[] = "(\002 (g,g)=\002,10d10.3,/(7x,10d10.3))";
    static char fmt_1005[] = "(\002 start with variables 1 and\002,i4)";
    static char fmt_1006[] = "(\002 (s,s)=\002,d12.4,\002  variable\002,i4,\002 (\002,d12.4,\002) coming in.\002)";
    static char fmt_1007[] = "(\002 variable\002,i4,\002 (\002,i4,\002) =\002,d11.3,\002 going out.\002,\002  feasible (s,s)=\002,d11.4,\002 unfeasible=\002,d11.4)";
    static char fmt_1008[] = "(\002 initial corral\002/(20i6))";
    static char fmt_1010[] = "(\002   epsilon =\002,d10.3)";
    static char fmt_1011[] = "(\002 x=\002,10d11.3,/(3x,10d11.3))";
    static char fmt_1012[] = "(\002 choleski,\002,10d11.3,/(10x,10d11.3))";
    static char fmt_1013[] = "(\002   duplicate variable \002,i3)";
    static char fmt_1014[] = "(\002 finished with\002,i3,\002 gradients\002,i3,\002 variables.\002/\002 (s,s)=\002,d11.4,\002 test=\002,d11.4/\002 cost of the extra constraint u=\002,d12.5)";
    static char fmt_1015[] = "(20i6)";
    static char fmt_1016[] = "(\002 fprf2 is apparently looping\002)";
    static char fmt_1018[] = "(//)";
    static char fmt_1019[] = "(\002 error from fprf2. old solution already optimal\002)";
    static char fmt_1020[] = "(\002 (s,s)=\002,d12.4,\002  u1=\002,d12.3,\002  variable 1 coming in.\002)";

     
    integer i__1, i__2, i__3, i__4;
    doublereal d__1;

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static doublereal gama;
    static integer mek01, mekk, incr;
    static doublereal teta;
    static integer ment, i__, j, k, l, niter, itmax, j0, j1, j2, k1, k0;
    static doublereal u2, v1, v2;
    static integer k00, jj, jk, kk;
    static doublereal ps, sp;
    static integer nt1;
    static doublereal ps1;
    static integer nv1;
    static doublereal ps0, ps2, w1s, w2s;
    static integer mej, mek;
    static doublereal det, dmu, ps12, w12s;

     
    static cilist io___2097 = { 0, 0, 0, fmt_1003, 0 };
    static cilist io___2099 = { 0, 0, 0, fmt_1010, 0 };
    static cilist io___2101 = { 0, 0, 0, fmt_1004, 0 };
    static cilist io___2103 = { 0, 0, 0, fmt_1008, 0 };
    static cilist io___2109 = { 0, 0, 0, fmt_1019, 0 };
    static cilist io___2111 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2113 = { 0, 0, 0, fmt_1005, 0 };
    static cilist io___2114 = { 0, 0, 0, fmt_1011, 0 };
    static cilist io___2115 = { 0, 0, 0, fmt_1016, 0 };
    static cilist io___2120 = { 0, 0, 0, fmt_1006, 0 };
    static cilist io___2121 = { 0, 0, 0, fmt_1020, 0 };
    static cilist io___2123 = { 0, 0, 0, fmt_1013, 0 };
    static cilist io___2128 = { 0, 0, 0, fmt_1012, 0 };
    static cilist io___2130 = { 0, 0, 0, fmt_1012, 0 };
    static cilist io___2138 = { 0, 0, 0, fmt_1007, 0 };
    static cilist io___2142 = { 0, 0, 0, fmt_1014, 0 };
    static cilist io___2143 = { 0, 0, 0, fmt_1015, 0 };
    static cilist io___2144 = { 0, 0, 0, fmt_1018, 0 };
     
    --al;
    --w2;
    --w1;
    --y;
    --xpr;
    --rr;
    --e;
    --a;
    --ic;
    --jc;
    --r__;
 
    niter = 0;
    nt1 = *ntot + 1;
    itmax = *ntot * 10;
    incr = 0;
    k00 = 1;
    w1s = 0.;
    w2s = 0.;
    w12s = 0.;
    gama = .99;
 
    if (*imp <= 7) {
	goto L100;
    }
    io___2097.ciunit = *io;
    s_wsfe(&io___2097);
    i__1 = nt1;
    for (j = 1; j <= i__1; ++j) {
	do_fio(&c__1, (char *)&a[j], (ftnlen)sizeof(doublereal));
    }
    e_wsfe();
    io___2099.ciunit = *io;
    s_wsfe(&io___2099);
    do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal));
    e_wsfe();
    i__1 = nt1;
    for (j = 1; j <= i__1; ++j) {
	mej = (j - 1) * *mm1;
	io___2101.ciunit = *io;
	s_wsfe(&io___2101);
	i__2 = j;
	for (jj = 1; jj <= i__2; ++jj) {
	    do_fio(&c__1, (char *)&r__[mej + jj], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
 
    }

 

L100:
    if (*iflag != 3) {
	goto L110;
    }
    if (*imp > 6) {
	io___2103.ciunit = *io;
	s_wsfe(&io___2103);
	i__1 = *nv;
	for (k = 1; k <= i__1; ++k) {
	    do_fio(&c__1, (char *)&jc[k], (ftnlen)sizeof(integer));
	}
	e_wsfe();
    }
    j0 = nt1;
    ps = fprf2c_ .u1 * (a[nt1] - *eps);
    ment = (nt1 - 1) * *mm1;
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	jk = ment + jc[k];
 
	ps += xpr[k] * r__[jk];
    }
    if (ps < *s2) {
	goto L107;
    }
    if (*imp > 0) {
	io___2109.ciunit = *io;
	s_wsfe(&io___2109);
	e_wsfe();
    }
    *iflag = 1;
    return 0;
L107:
    ++(*nv);
    ++ fprf2c_ .nc;
    jc[*nv] = j0;
    niter = 1;
    goto L300;
L110:
    if (*iflag <= 1) {
	goto L140;
    }
 
    i__1 = nt1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	ic[i__] = 0;
    }
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	jk = jc[k];
 
	ic[jk] = 1;
    }
    ic[nt1] = 1;
 
L140:
    jc[1] = 1;
    *nv = 2;
    fprf2c_ .nc = 1;
    jc[2] = 0;
    i__1 = nt1;
    for (j = 2; j <= i__1; ++j) {
	if (a[j] > *eps) {
	    goto L150;
	}
	jc[2] = j;
L150:
	;
    }
    if (jc[2] > 0) {
	goto L160;
    }
    if (*imp > 0) {
	io___2111.ciunit = *io;
	s_wsfe(&io___2111);
	e_wsfe();
    }
    *iflag = 2;
    return 0;
L160:
    j = jc[2];
    rr[1] = 1.;
    jj = (j - 1) * *mm1 + j;
    ps = r__[jj] + 1.;
    if (ps > 0.) {
	goto L170;
    }
    *iflag = 3;
    return 0;
L170:
    rr[2] = sqrt(ps);
    r__[2] = a[j];
    i__1 = nt1;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xpr[i__] = 0.;
    }
    xpr[1] = *eps - a[j];
    xpr[2] = 1.;
    fprf2c_ .u1 = 0.;
    u2 = -r__[jj];
    if (*imp > 6) {
	io___2113.ciunit = *io;
	s_wsfe(&io___2113);
	do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
	e_wsfe();
    }

 

L200:
    ++niter;
    if (*imp > 6) {
	io___2114.ciunit = *io;
	s_wsfe(&io___2114);
	i__1 = *nv;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_fio(&c__1, (char *)&xpr[i__], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }
    if (niter <= itmax) {
	goto L205;
    }
    if (*imp > 0) {
	io___2115.ciunit = *io;
	s_wsfe(&io___2115);
	e_wsfe();
    }
    *iflag = 4;
    return 0;
L205:
    *s2 = -(*eps) * fprf2c_ .u1 - u2;
    if (*s2 <= *eta) {
	goto L900;
    }
    sp = gama * *s2;
 
 
    j0 = 0;
    i__1 = nt1;
    for (j = 2; j <= i__1; ++j) {
	ps = fprf2c_ .u1 * (a[j] - *eps);
	i__2 = *nv;
	for (k = 1; k <= i__2; ++k) {
	    jj = jc[k];
	    if (jj == 1) {
		goto L210;
	    }
	    j1 = (( j ) >= ( jj ) ? ( j ) : ( jj )) ;
	    j2 = (( j ) <= ( jj ) ? ( j ) : ( jj )) ;
	    jj = (j1 - 1) * *mm1 + j2;
	    ps += xpr[k] * r__[jj];
L210:
	    ;
	}
	y[j] = ps;
	if (*iflag != 2) {
	    goto L220;
	}
	if (ic[j] != 1) {
	    goto L220;
	}
	if (ps >= sp) {
	    goto L220;
	}
	j0 = j;
	sp = ps;
L220:
	;
    }
    if (j0 == 0) {
	goto L240;
    }
    if (sp >= gama * *s2) {
	goto L240;
    }
    ps1 = (d__1 = fprf2c_ .u1 * (*eps - a[j0]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	j = jc[k];
	if (j == j0) {
	    goto L240;
	}
	if (j == 1) {
	    goto L230;
	}
	j1 = (( j0 ) >= ( j ) ? ( j0 ) : ( j )) ;
	j2 = (( j0 ) <= ( j ) ? ( j0 ) : ( j )) ;
	jj = (j1 - 1) * *mm1 + j2;
	ps1 += xpr[k] * (d__1 = fprf2c_ .u1 * (*eps * 2. - a[j]) + y[j] * 2. 
		- r__[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
L230:
	;
    }
    ps1 = ps1 * 1e3 * *zero;
    if (sp > *s2 - ps1) {
	goto L240;
    }
    ic[j0] = 0;
    goto L280;
 
L240:
    j0 = 0;
    sp = gama * *s2;
    i__1 = nt1;
    for (j = 2; j <= i__1; ++j) {
	if (*iflag == 2 && ic[j] == 1) {
	    goto L260;
	}
	if (y[j] >= sp) {
	    goto L260;
	}
	sp = y[j];
	j0 = j;
L260:
	;
    }
    if (j0 == 0) {
	goto L290;
    }
    ps1 = (d__1 = fprf2c_ .u1 * (*eps - a[j0]), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	j = jc[k];
	if (j == 1) {
	    goto L270;
	}
	j1 = (( j0 ) >= ( j ) ? ( j0 ) : ( j )) ;
	j2 = (( j0 ) <= ( j ) ? ( j0 ) : ( j )) ;
	jj = (j1 - 1) * *mm1 + j2;
	ps1 += xpr[k] * (d__1 = fprf2c_ .u1 * (*eps * 2. - a[j]) + y[j] * 2. 
		- r__[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
L270:
	;
    }
    ps1 = ps1 * 1e3 * *zero;
    if (sp > *s2 - ps1) {
	goto L290;
    }
L280:
    ++ fprf2c_ .nc;
    ++(*nv);
    jc[*nv] = j0;
    if (*imp > 6) {
	io___2120.ciunit = *io;
	s_wsfe(&io___2120);
	do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&j0, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&sp, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    goto L300;
 
L290:
    if (fprf2c_ .u1 >= -((doublereal) (*nv)) * *zero) {
	goto L900;
    }
    j0 = 1;
    ++(*nv);
    jc[*nv] = 1;
    if (*imp > 6) {
	io___2121.ciunit = *io;
	s_wsfe(&io___2121);
	do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)& fprf2c_ .u1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 

L300:
    nv1 = *nv - 1;
    i__1 = nv1;
    for (k = 1; k <= i__1; ++k) {
	if (jc[k] != j0) {
	    goto L305;
	}
	if (*imp > 0) {
	    io___2123.ciunit = *io;
	    s_wsfe(&io___2123);
	    do_fio(&c__1, (char *)&j0, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*iflag = 3;
	return 0;
L305:
	;
    }
    j = jc[1];
    j1 = (( j ) >= ( j0 ) ? ( j ) : ( j0 )) ;
    j2 = (( j ) <= ( j0 ) ? ( j ) : ( j0 )) ;
    jj = (j1 - 1) * *mm1 + j2;
    r__[*nv] = (a[j] * a[j0] + e[j] * e[j0] + r__[jj]) / rr[1];
    ps0 = r__[*nv] * r__[*nv];
    if (nv1 == 1) {
	goto L330;
    }
    i__1 = nv1;
    for (k = 2; k <= i__1; ++k) {
	j = jc[k];
	j1 = (( j ) >= ( j0 ) ? ( j ) : ( j0 )) ;
	j2 = (( j ) <= ( j0 ) ? ( j ) : ( j0 )) ;
	jj = (j1 - 1) * *mm1 + j2;
	ps = a[j] * a[j0] + e[j] * e[j0] + r__[jj];
	k1 = k - 1;
	i__2 = k1;
	for (kk = 1; kk <= i__2; ++kk) {
	    j1 = (kk - 1) * *mm1 + k;
	    j2 = (kk - 1) * *mm1 + *nv;
 
	    ps -= r__[j1] * r__[j2];
	}
	mek = k1 * *mm1 + *nv;
	r__[mek] = ps / rr[k];
 
	ps0 += r__[mek] * r__[mek];
    }
    jj = (j0 - 1) * *mm1 + j0;
    ps0 = a[j0] * a[j0] + e[j0] * e[j0] + r__[jj] - ps0;
    if (ps0 > 0.) {
	goto L330;
    }
    *iflag = 3;
    return 0;
L330:
    rr[*nv] = sqrt(ps0);
    if (niter <= 1) {
	goto L400;
    }
    incr = 1;
    k00 = *nv;

 

L400:
    k = k00;
    if (k > *nv) {
	goto L430;
    }
    if (*imp <= 7) {
	goto L410;
    }
    io___2128.ciunit = *io;
    s_wsfe(&io___2128);
    do_fio(&c__1, (char *)&rr[1], (ftnlen)sizeof(doublereal));
    e_wsfe();
    if (*nv == 1) {
	goto L410;
    }
    i__1 = *nv;
    for (l = 2; l <= i__1; ++l) {
	k1 = l - 1;
	io___2130.ciunit = *io;
	s_wsfe(&io___2130);
	i__2 = k1;
	for (kk = 1; kk <= i__2; ++kk) {
	    do_fio(&c__1, (char *)&r__[(kk - 1) * *mm1 + l], (ftnlen)sizeof(
		    doublereal));
	}
	do_fio(&c__1, (char *)&rr[l], (ftnlen)sizeof(doublereal));
	e_wsfe();
 
    }
L410:
    j = jc[k];
    ps1 = a[j];
    ps2 = e[j];
    if (k == 1) {
	goto L420;
    }
    k1 = k - 1;
    i__1 = k1;
    for (kk = 1; kk <= i__1; ++kk) {
	jj = (kk - 1) * *mm1 + k;
	ps0 = r__[jj];
	ps1 -= ps0 * w1[kk];
 
	ps2 -= ps0 * w2[kk];
    }
L420:
    ps0 = rr[k];
    w1[k] = ps1 / ps0;
    w2[k] = ps2 / ps0;
    ++k;
    if (k <= *nv) {
	goto L410;
    }
 
L430:
    k = 1;
    if (incr == 1) {
	k = *nv;
    }
L440:
    w1s += w1[k] * w1[k];
    w2s += w2[k] * w2[k];
    w12s += w1[k] * w2[k];
    ++k;
    if (k <= *nv) {
	goto L440;
    }
    det = w1s * w2s - w12s * w12s;
    ps2 = w2s * *eps - w12s;
    ps1 = w1s - w12s * *eps;
 
    v1 = ps2 / det;
    v2 = ps1 / det;
 
    fprf2c_ .u1 = *eps - v1;
    u2 = 1. - v2;
    if (*nv == fprf2c_ .nc + 1) {
	fprf2c_ .u1 = 0.;
    }
 
    y[*nv] = (v1 * w1[*nv] + v2 * w2[*nv]) / rr[*nv];
    if (*nv == 1) {
	goto L500;
    }
    i__1 = *nv;
    for (l = 2; l <= i__1; ++l) {
	k = *nv - l + 1;
	k1 = k + 1;
	ps = v1 * w1[k] + v2 * w2[k];
	mek = (k - 1) * *mm1;
	i__2 = *nv;
	for (kk = k1; kk <= i__2; ++kk) {
	    mej = mek + kk;
 
	    ps -= r__[mej] * y[kk];
	}
 
	y[k] = ps / rr[k];
    }

 

L500:
    dmu = -(*zero) * *eps;
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	if (jc[k] == 1) {
	    goto L520;
	}
	if (y[k] <= *zero) {
	    goto L550;
	}
	goto L530;
L520:
	if (y[k] <= dmu) {
	    goto L550;
	}
L530:
	;
    }
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
 
	xpr[k] = y[k];
    }
    goto L200;
 
L550:
    teta = 0.;
    k0 = k;
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	if (y[k] >= 0.) {
	    goto L560;
	}
	ps = y[k] / (y[k] - xpr[k]);
	if (teta >= ps) {
	    goto L560;
	}
	teta = ps;
	k0 = k;
L560:
	;
    }
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	ps = teta * xpr[k] + (1. - teta) * y[k];
	if (ps <= *zero) {
	    ps = 0.;
	}
 
	xpr[k] = ps;
    }
    if (*imp <= 6) {
	goto L600;
    }
    ps1 = 0.;
    ps2 = 0.;
    i__1 = *nv;
    for (k = 1; k <= i__1; ++k) {
	i__2 = *nv;
	for (kk = 1; kk <= i__2; ++kk) {
 
	    i__3 = jc[k], i__4 = jc[kk];
	    j1 = (( i__3 ) >= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
 
	    i__3 = jc[k], i__4 = jc[kk];
	    j2 = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
	    jj = (j1 - 1) * *mm1 + j2;
	    ps1 += xpr[k] * xpr[kk] * r__[jj];
	    ps2 += y[k] * y[kk] * r__[jj];
 
	}
    }

 

L600:
    --(*nv);
    incr = 0;
    k00 = k0;
    w1s = 0.;
    w2s = 0.;
    w12s = 0.;
    l = jc[k0];
    if (l != 1) {
	-- fprf2c_ .nc;
    }
    if (*imp > 6) {
	io___2138.ciunit = *io;
	s_wsfe(&io___2138);
	do_fio(&c__1, (char *)&k0, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&l, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&y[k0], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ps1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ps2, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (k0 > *nv) {
	goto L400;
    }
    k1 = k0 - 1;
    i__2 = *nv;
    for (k = k0; k <= i__2; ++k) {
	xpr[k] = xpr[k + 1];
	if (k0 == 1) {
	    goto L620;
	}
	i__1 = k1;
	for (kk = 1; kk <= i__1; ++kk) {
	    mek = (kk - 1) * *mm1 + k;
 
	    r__[mek] = r__[mek + 1];
	}
L620:
	jc[k] = jc[k + 1];
    }
    xpr[*nv + 1] = 0.;
L630:
    mek = (k0 - 1) * *mm1 + k0 + 1;
    ps = r__[mek];
    ps12 = rr[k0 + 1];
    ps0 = sqrt(ps * ps + ps12 * ps12);
    ps /= ps0;
    ps12 /= ps0;
    rr[k0] = ps0;
    if (k0 == *nv) {
	goto L400;
    }
    k1 = k0 + 1;
    mek01 = (k0 - 1) * *mm1;
    mek = k0 * *mm1;
    mekk = mek - *mm1;
    i__2 = *nv;
    for (k = k1; k <= i__2; ++k) {
	j1 = mekk + k;
	j2 = mek + k;
	r__[j1] = ps * r__[j1 + 1] + ps12 * r__[j2 + 1];
	if (k > k1) {
	    r__[j2] = ps2;
	}
 
	ps2 = -ps12 * r__[j1 + 1] + ps * r__[j2 + 1];
    }
    r__[j2 + 1] = ps2;
    ++k0;
    goto L630;

 

L900:
    *iflag = 0;
    i__2 = *ntot;
    for (j = 1; j <= i__2; ++j) {
 
	al[j] = 0.;
    }
    i__2 = *nv;
    for (k = 1; k <= i__2; ++k) {
	j = jc[k] - 1;
	if (j != 0) {
	    al[j] = xpr[k];
	}
 
    }
    *u = fprf2c_ .u1;
    if (*imp <= 5) {
	return 0;
    }
    io___2142.ciunit = *io;
    s_wsfe(&io___2142);
    do_fio(&c__1, (char *)& fprf2c_ .nc, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*nv), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*s2), (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&sp, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)& fprf2c_ .u1, (ftnlen)sizeof(doublereal));
    e_wsfe();
    io___2143.ciunit = *io;
    s_wsfe(&io___2143);
    i__2 = *nv;
    for (k = 1; k <= i__2; ++k) {
	do_fio(&c__1, (char *)&jc[k], (ftnlen)sizeof(integer));
    }
    e_wsfe();
    io___2144.ciunit = *io;
    s_wsfe(&io___2144);
    e_wsfe();
    return 0;
}  

  int frdf1_(prosca, n, ntot, ninf, kgrad, al, q, s, epsn, aps,
	 anc, mm1, r__, e, ic, izs, rzs, dzs)
  int (*prosca) ();
integer *n, *ntot, *ninf, *kgrad;
doublereal *al, *q, *s, *epsn, *aps, *anc;
integer *mm1;
doublereal *r__, *e;
integer *ic, *izs;
real *rzs;
doublereal *dzs;
{
     
    integer i__1, i__2;

     
    static integer i__, j, k;
    static doublereal z__, z1, z2;
    static integer nj, nn, nt1, njk;



 
 
 

     
    --s;
    --q;
    --ic;
    --e;
    --anc;
    --aps;
    --epsn;
    --al;
    --r__;
    --izs;
    --rzs;
    --dzs;

     
    if (*ntot <= *ninf) {
	goto L900;
    }
    if (*ninf > 0) {
	goto L100;
    }

 

    *ntot = 0;
    *kgrad = 0;
    goto L900;

 
L100:
    nt1 = 0;
    i__1 = *ntot;
    for (j = 1; j <= i__1; ++j) {
	if (al[j] == 0. && epsn[j] != 0.) {
	    goto L150;
	}
	++nt1;
	ic[nt1] = j;
	if (j == nt1) {
	    goto L130;
	}
	nj = *n * (j - 1);
	nn = *n * (nt1 - 1);
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++nn;
	    ++nj;
 
	    q[nn] = q[nj];
	}
	al[nt1] = al[j];
	epsn[nt1] = epsn[j];
	aps[nt1] = aps[j];
	anc[nt1] = anc[j];
	e[nt1 + 1] = e[j + 1];
L130:
	if (epsn[j] == 0.) {
	    *kgrad = nt1;
	}
	nn = nt1 * *mm1 + 1;
	nj = j * *mm1 + 1;
	i__2 = nt1;
	for (k = 1; k <= i__2; ++k) {
	    njk = nj + ic[k];
	    ++nn;
 
	    r__[nn] = r__[njk];
	}
L150:
	;
    }
    *ntot = nt1;
    if (*ntot <= *ninf) {
	goto L900;
    }

 
 

    (*prosca)(n, &s[1], &s[1], &r__[*mm1 + 2], &izs[1], &rzs[1], &dzs[1]);
    e[2] = 1.;
    z__ = 0.;
    z1 = 0.;
    z2 = 0.;
    i__1 = *ntot;
    for (k = 1; k <= i__1; ++k) {
	z1 += al[k] * aps[k];
	z2 += al[k] * anc[k];
 
	z__ += al[k] * epsn[k];
    }
    aps[1] = z1;
    anc[1] = z2;
    epsn[1] = z__;
    if (*ninf > 1) {
	goto L400;
    }
    *ntot = 1;
    *kgrad = 0;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	q[i__] = s[i__];
    }
    goto L900;
 
L400:
    nn = (*kgrad - 1) * *n;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nj = *n + i__;
	++nn;
	q[nj] = q[nn];
 
	q[i__] = s[i__];
    }
    e[3] = 1.;
    nn = (*mm1 + 1) * *kgrad + 1;
    r__[(*mm1 << 1) + 3] = r__[nn];
    (*prosca)(n, &q[*n + 1], &s[1], &r__[(*mm1 << 1) + 2], &izs[1], &rzs[1], &
	    dzs[1]);
    aps[2] = 0.;
    anc[2] = 0.;
    epsn[2] = 0.;
    *kgrad = 2;
    *ntot = 2;
L900:
    return 0;
}  

  int fremf1_(prosca, iflag, n, ntot, nta, mm1, p, alfa, e, a, 
	r__, izs, rzs, dzs)
  int (*prosca) ();
integer *iflag, *n, *ntot, *nta, *mm1;
doublereal *p, *alfa, *e, *a, *r__;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    integer i__1, i__2;

     
    static integer mekk, i__, j, jj, kk, ni, nj, nt1, mej, nij, nta1, nta2;


 
 

 
 

 

 
 

     
    --alfa;
    --a;
    --e;
    --p;
    --r__;
    --izs;
    --rzs;
    --dzs;

     
    nt1 = *ntot + 1;
    nta1 = *nta + 1;
    if (*iflag > 0) {
	goto L50;
    }

 
 

    i__1 = *ntot;
    for (j = 1; j <= i__1; ++j) {
	jj = (j - 1) * *mm1 + 1;
 
	r__[jj] = 0.;
    }
    a[1] = 1.;
    e[1] = 0.;
    if (nta1 == 1) {
	goto L50;
    }
    i__1 = nta1;
    for (j = 2; j <= i__1; ++j) {
	e[j] = 1.;
	nj = (j - 2) * *n;
	mej = (j - 1) * *mm1;
	i__2 = j;
	for (i__ = 2; i__ <= i__2; ++i__) {
	    ni = (i__ - 2) * *n;

 
 
 

	    nij = mej + i__;
	    (*prosca)(n, &p[ni + 1], &p[nj + 1], &r__[nij], &izs[1], &rzs[1], 
		    &dzs[1]);
 
	}
    }


L50:
    nta2 = *nta + 2;

 

    if (nta2 > nt1) {
	goto L100;
    }
    i__2 = nt1;
    for (kk = nta2; kk <= i__2; ++kk) {
	mekk = (kk - 1) * *mm1;
	e[kk] = 1.;
	r__[mekk + 1] = 0.;
	nj = (kk - 2) * *n;
	i__1 = kk;
	for (i__ = 2; i__ <= i__1; ++i__) {
	    ni = (i__ - 2) * *n;

 
 
 

	    nij = mekk + i__;
	    (*prosca)(n, &p[ni + 1], &p[nj + 1], &r__[nij], &izs[1], &rzs[1], 
		    &dzs[1]);
 
	}
    }

 
 

    i__1 = nt1;
    for (i__ = 2; i__ <= i__1; ++i__) {
 
	a[i__] = alfa[i__ - 1];
    }
L100:
    return 0;
}  

  int fuclid_(n, a, b, ps, izs, rzs, dzs)
integer *n;
doublereal *a, *b, *ps;
integer *izs;
real *rzs;
doublereal *dzs;
{
    extern doublereal ddot_();

    *ps = ddot_(n, a, &c__1, b, &c__1);
}  

  int gcbd_(indgc, simul, nomf, n, x, f, g, imp, io, zero, 
	napmax, itmax, epsf, epsg, epsx, df0, binf, bsup, nfac, vect, nvect, 
	ivect, nivect, izs, rzs, dzs, nomf_len)
integer *indgc;
  int (*simul) ();
char *nomf;
integer *n;
doublereal *x, *f, *g;
integer *imp, *io;
doublereal *zero;
integer *napmax, *itmax;
doublereal *epsf, *epsg, *epsx, *df0, *binf, *bsup;
integer *nfac;
doublereal *vect;
integer *nvect, *ivect, *nivect, *izs;
real *rzs;
doublereal *dzs;
ftnlen nomf_len;
{
     
    static char fmt_123[] = "(\002 gcbd : retour avec indgc=\002,i8)";
    static char fmt_1000[] = "(\002 gcbd:insuffisance memoire; nvect=\002,i5,\002devrait etre:\002,i5)";
    static char fmt_2000[] = "(\002 gcbd:insuffisance memoire; nivect=\002,i5,\002devrait etre:\002,i5)";

     
    integer i__1;
    doublereal d__1, d__2;

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static integer ialg[15], nfin, ndir, i__, ndiag;
    extern   int zgcbd_();
    static doublereal aa;
    static integer ii, nd, ng, ns, nt, nindic, ny, nz, nindex, nx2;
    static doublereal alg[15];
    static integer nys, nzs;

     
    static cilist io___2171 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___2174 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___2186 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2189 = { 0, 0, 0, fmt_2000, 0 };


 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 

 
 
 
 
 
 
 
 
 

 
 
 
 
 

 
 
 
 
 
 
 
 

 


 
     
    --bsup;
    --binf;
    --epsx;
    --g;
    --x;
    --vect;
    --ivect;
    --izs;
    --rzs;
    --dzs;

     
    nt = 2;
    alg[0] = 1e-5;
    alg[1] = 1e6;
    alg[5] = .5;
    alg[8] = .5;

    ialg[0] = 1;
    ialg[1] = 0;
    ialg[2] = 2;
    ialg[3] = 0;
    ialg[4] = 0;
    ialg[5] = 2;
    ialg[6] = 1;
    ialg[7] = 4;
    ialg[8] = 12;

 
 
    i__1 = (( *n ) <= ( *napmax ) ? ( *n ) : ( *napmax )) ;
    ii = (( i__1 ) <= ( *itmax ) ? ( i__1 ) : ( *itmax )) ;
    if (ii > 0) {
	goto L10;
    }
    *indgc = -11;
    if (*imp > 0) {
	io___2171.ciunit = *io;
	s_wsfe(&io___2171);
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L10:
 
    d__1 = (( *zero ) <= ( *epsg ) ? ( *zero ) : ( *epsg )) ;
    aa = (( d__1 ) <= ( *df0 ) ? ( d__1 ) : ( *df0 )) ;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = aa, d__2 = epsx[i__];
	aa = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if (aa > 0.) {
	goto L12;
    }
    *indgc = -12;
    if (*imp > 0) {
	io___2174.ciunit = *io;
	s_wsfe(&io___2174);
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L12:

 
    ny = 1;
    ns = nt * *n + ny;
    nz = nt * *n + ns;
    nys = nt * *n + nz;
    nzs = nt + nys;
    nd = nt + nzs;
    ng = *n + nd;
    nx2 = *n + ng;
    ndir = *n + nx2;
    ndiag = *n + ndir;
    nfin = *n + ndiag;

    if (nfin > *nvect) {
	io___2186.ciunit = *io;
	s_wsfe(&io___2186);
	do_fio(&c__1, (char *)&nfin, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nvect), (ftnlen)sizeof(integer));
	e_wsfe();
	*indgc = -14;
	return 0;
    }

    nindic = 1;
    nindex = *n + nindic;
    nfin = nt + nindex;
    if (nfin > *nivect) {
	io___2189.ciunit = *io;
	s_wsfe(&io___2189);
	do_fio(&c__1, (char *)&nfin, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nivect), (ftnlen)sizeof(integer));
	e_wsfe();
	*indgc = -14;
	return 0;
    }

    zgcbd_(simul, n, &binf[1], &bsup[1], &x[1], f, &g[1], zero, napmax, itmax,
	     indgc, &ivect[nindic], nfac, imp, io, &epsx[1], epsf, epsg, &
	    vect[ndir], df0, &vect[ndiag], &vect[nx2], &izs[1], &rzs[1], &dzs[
	    1], &vect[ny], &vect[ns], &vect[nz], &vect[nys], &vect[nzs], &nt, 
	    &ivect[nindex], &vect[nd], &vect[ng], alg, ialg, nomf, 6L);
    return 0;
}  

  int gcp_(n, index, indic, np, nt, y, s, z__, ys, zs, diag, b,
	 x, d__, g, eps)
integer *n, *index, *indic, *np, *nt;
doublereal *y, *s, *z__, *ys, *zs, *diag, *b, *x, *d__, *g, *eps;
{
     
    integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1;

     
    static doublereal beta;
    static integer iter, i__;
    extern   int calbx_();
    static integer itmax;
    static doublereal s0, s1, s2, dg, ro, d2a, eps0, eps1;


 
 
 


 
     
    --g;
    --d__;
    --x;
    --b;
    --diag;
    --indic;
    --zs;
    --ys;
    z_dim1 = *nt;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;
    --index;

     
    eps0 = (float)1e-5;
    eps1 = (float)1e-5;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L100;
	}
	x[i__] = -b[i__] / diag[i__];
L100:
	;
    }

    calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1]
	    , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L110;
	}
	g[i__] += b[i__];
L110:
	;
    }

 
 
 
    s0 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L120;
	}
	s0 += g[i__] * g[i__] / diag[i__];
L120:
	;
    }
    if (s0 < 1e-18) {
	return 0;
    }
    s1 = s0;
 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L130;
	}
	d__[i__] = -g[i__] / diag[i__];
L130:
	;
    }

 
    dg = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L135;
	}
	dg += d__[i__] * g[i__];
L135:
	;
    }
    calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1]
	    , &z__[z_offset], &zs[1], &d__[1], &diag[1], &g[1]);
    d2a = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L140;
	}
	d2a += d__[i__] * g[i__];
L140:
	;
    }

    ro = -dg / d2a;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L150;
	}
	x[i__] += ro * d__[i__];
L150:
	;
    }
    calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1]
	    , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L170;
	}
	g[i__] += b[i__];
L170:
	;
    }

 
    iter = 0;
    itmax = *np << 1;
L10:
    ++iter;
    if (iter > itmax) {
	return 0;
    }
 
    s2 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L200;
	}
	s2 += g[i__] * g[i__] / diag[i__];
L200:
	;
    }
    if (s2 / s0 < *eps) {
	return 0;
    }
 
    beta = s2 / s1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L210;
	}
	d__[i__] = -g[i__] / diag[i__] + beta * d__[i__];
L210:
	;
    }
    s1 = s2;

 
    dg = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L215;
	}
	dg += d__[i__] * g[i__];
L215:
	;
    }
    calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1]
	    , &z__[z_offset], &zs[1], &d__[1], &diag[1], &g[1]);
    d2a = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L220;
	}
	d2a += d__[i__] * g[i__];
L220:
	;
    }

    ro = -dg / d2a;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L230;
	}
	x[i__] += ro * d__[i__];
L230:
	;
    }
    calbx_(n, &index[1], &indic[1], nt, np, &y[y_offset], &s[s_offset], &ys[1]
	    , &z__[z_offset], &zs[1], &x[1], &diag[1], &g[1]);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > 0) {
	    goto L240;
	}
	g[i__] += b[i__];
L240:
	;
    }
    goto L10;
}  

  int hybrd_(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, 
	diag, mode, factor, nprint, info, nfev, fjac, ldfjac, r__, lr, qtf, 
	wa1, wa2, wa3, wa4)
  int (*fcn) ();
integer *n;
doublereal *x, *fvec, *xtol;
integer *maxfev, *ml, *mu;
doublereal *epsfcn, *diag;
integer *mode;
doublereal *factor;
integer *nprint, *info, *nfev;
doublereal *fjac;
integer *ldfjac;
doublereal *r__;
integer *lr;
doublereal *qtf, *wa1, *wa2, *wa3, *wa4;
{
     

    static doublereal one = 1.;
    static doublereal p1 = .1;
    static doublereal p5 = .5;
    static doublereal p001 = .001;
    static doublereal p0001 = 1e-4;
    static doublereal zero = 0.;

     
    integer fjac_dim1, fjac_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    static logical sing;
    static integer iter;
    static doublereal temp;
    static integer msum, i__, j, l, iflag;
    static doublereal delta;
    extern   int qrfac_();
    static logical jeval;
    static integer ncsuc;
    static doublereal ratio;
    extern doublereal enorm_();
    static doublereal fnorm;
    extern   int qform_(), fdjac1_();
    static doublereal pnorm, xnorm, fnorm1;
    extern   int r1updt_();
    static integer nslow1, nslow2;
    extern doublereal dlamch_();
    extern   int r1mpyq_();
    static integer ncfail;
    extern   int dogleg_();
    static doublereal actred, epsmch, prered;
    static integer jm1, iwa[1];
    static doublereal sum;
     
    --wa4;
    --wa3;
    --wa2;
    --wa1;
    --qtf;
    --diag;
    --fvec;
    --x;
    fjac_dim1 = *ldfjac;
    fjac_offset = fjac_dim1 + 1;
    fjac -= fjac_offset;
    --r__;

     

 

    epsmch = dlamch_("p", 1L);

    *info = 0;
    iflag = 0;
    *nfev = 0;

 

    if (*n <= 0 || *xtol < zero || *maxfev <= 0 || *ml < 0 || *mu < 0 || *
	    factor <= zero || *ldfjac < *n || *lr < *n * (*n + 1) / 2) {
	goto L300;
    }
    if (*mode != 2) {
	goto L20;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (diag[j] <= zero) {
	    goto L300;
	}
 
    }
L20:

 
 

    iflag = 1;
    (*fcn)(n, &x[1], &fvec[1], &iflag);
    *nfev = 1;
    if (iflag < 0) {
	goto L300;
    }
    fnorm = enorm_(n, &fvec[1]);

 
 

 
    i__1 = *ml + *mu + 1;
    msum = (( i__1 ) <= ( *n ) ? ( i__1 ) : ( *n )) ;

 

    iter = 1;
    ncsuc = 0;
    ncfail = 0;
    nslow1 = 0;
    nslow2 = 0;

 

L30:
    jeval = (1) ;

 

    iflag = 2;
    fdjac1_(fcn, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, ml, 
	    mu, epsfcn, &wa1[1], &wa2[1]);
    *nfev += msum;
    if (iflag < 0) {
	goto L300;
    }

 

    qrfac_(n, n, &fjac[fjac_offset], ldfjac, &c_false, iwa, &c__1, &wa1[1], &
	    wa2[1], &wa3[1]);

 
 

    if (iter != 1) {
	goto L70;
    }
    if (*mode == 2) {
	goto L50;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	diag[j] = wa2[j];
	if (wa2[j] == zero) {
	    diag[j] = one;
	}
 
    }
L50:

 
 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa3[j] = diag[j] * x[j];
 
    }
    xnorm = enorm_(n, &wa3[1]);
    delta = *factor * xnorm;
    if (delta == zero) {
	delta = *factor;
    }
L70:

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	qtf[i__] = fvec[i__];
 
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (fjac[j + j * fjac_dim1] == zero) {
	    goto L110;
	}
	sum = zero;
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    sum += fjac[i__ + j * fjac_dim1] * qtf[i__];
 
	}
	temp = -sum / fjac[j + j * fjac_dim1];
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    qtf[i__] += fjac[i__ + j * fjac_dim1] * temp;
 
	}
L110:
 
	;
    }

 

    sing = (0) ;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	l = j;
	jm1 = j - 1;
	if (jm1 < 1) {
	    goto L140;
	}
	i__2 = jm1;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    r__[l] = fjac[i__ + j * fjac_dim1];
	    l = l + *n - i__;
 
	}
L140:
	r__[l] = wa1[j];
	if (wa1[j] == zero) {
	    sing = (1) ;
	}
 
    }

 

    qform_(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]);

 

    if (*mode == 2) {
	goto L170;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
 
	d__1 = diag[j], d__2 = wa2[j];
	diag[j] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    }
L170:

 

L180:

 

    if (*nprint <= 0) {
	goto L190;
    }
    iflag = 0;
    if ((iter - 1) % *nprint == 0) {
	(*fcn)(n, &x[1], &fvec[1], &iflag);
    }
    if (iflag < 0) {
	goto L300;
    }
L190:

 

    dogleg_(n, &r__[1], lr, &diag[1], &qtf[1], &delta, &wa1[1], &wa2[1], &wa3[
	    1]);

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa1[j] = -wa1[j];
	wa2[j] = x[j] + wa1[j];
	wa3[j] = diag[j] * wa1[j];
 
    }
    pnorm = enorm_(n, &wa3[1]);

 

    if (iter == 1) {
	delta = (( delta ) <= ( pnorm ) ? ( delta ) : ( pnorm )) ;
    }

 

    iflag = 1;
    (*fcn)(n, &wa2[1], &wa4[1], &iflag);
    ++(*nfev);
    if (iflag < 0) {
	goto L300;
    }
    fnorm1 = enorm_(n, &wa4[1]);

 

    actred = -one;
    if (fnorm1 < fnorm) {
 
	d__1 = fnorm1 / fnorm;
	actred = one - d__1 * d__1;
    }

 

    l = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sum = zero;
	i__2 = *n;
	for (j = i__; j <= i__2; ++j) {
	    sum += r__[l] * wa1[j];
	    ++l;
 
	}
	wa3[i__] = qtf[i__] + sum;
 
    }
    temp = enorm_(n, &wa3[1]);
    prered = zero;
    if (temp < fnorm) {
 
	d__1 = temp / fnorm;
	prered = one - d__1 * d__1;
    }

 
 

    ratio = zero;
    if (prered > zero) {
	ratio = actred / prered;
    }

 

    if (ratio >= p1) {
	goto L230;
    }
    ncsuc = 0;
    ++ncfail;
    delta = p5 * delta;
    goto L240;
L230:
    ncfail = 0;
    ++ncsuc;
    if (ratio >= p5 || ncsuc > 1) {
 
	d__1 = delta, d__2 = pnorm / p5;
	delta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if ((d__1 = ratio - one, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= p1) {
	delta = pnorm / p5;
    }
L240:

 

    if (ratio < p0001) {
	goto L260;
    }

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	x[j] = wa2[j];
	wa2[j] = diag[j] * x[j];
	fvec[j] = wa4[j];
 
    }
    xnorm = enorm_(n, &wa2[1]);
    fnorm = fnorm1;
    ++iter;
L260:

 

    ++nslow1;
    if (actred >= p001) {
	nslow1 = 0;
    }
    if (jeval) {
	++nslow2;
    }
    if (actred >= p1) {
	nslow2 = 0;
    }

 

    if (delta <= *xtol * xnorm || fnorm == zero) {
	*info = 1;
    }
    if (*info != 0) {
	goto L300;
    }

 

    if (*nfev >= *maxfev) {
	*info = 2;
    }
 
    d__1 = p1 * delta;
    if (p1 * (( d__1 ) >= ( pnorm ) ? ( d__1 ) : ( pnorm ))  <= epsmch * xnorm) {
	*info = 3;
    }
    if (nslow2 == 5) {
	*info = 4;
    }
    if (nslow1 == 10) {
	*info = 5;
    }
    if (*info != 0) {
	goto L300;
    }

 
 

    if (ncfail == 2) {
	goto L290;
    }

 
 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	sum = zero;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    sum += fjac[i__ + j * fjac_dim1] * wa4[i__];
 
	}
	wa2[j] = (sum - wa3[j]) / pnorm;
	wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm);
	if (ratio >= p0001) {
	    qtf[j] = sum;
	}
 
    }

 

    r1updt_(n, n, &r__[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing);
    r1mpyq_(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]);
    r1mpyq_(&c__1, n, &qtf[1], &c__1, &wa2[1], &wa3[1]);

 

    jeval = (0) ;
    goto L180;
L290:

 

    goto L30;
L300:

 

    if (iflag < 0) {
	*info = iflag;
    }
    iflag = 0;
    if (*nprint > 0) {
	(*fcn)(n, &x[1], &fvec[1], &iflag);
    }
    return 0;

 

}  

  int hybrd1_(fcn, n, x, fvec, tol, info, wa, lwa)
  int (*fcn) ();
integer *n;
doublereal *x, *fvec, *tol;
integer *info;
doublereal *wa;
integer *lwa;
{
     

    static doublereal factor = 100.;
    static doublereal one = 1.;
    static doublereal zero = 0.;

     
    integer i__1;

     
    static integer mode, nfev;
    static doublereal xtol;
    static integer j, index;
    extern   int hybrd_();
    static integer ml, lr, mu;
    static doublereal epsfcn;
    static integer maxfev, nprint;
    --fvec;
    --x;
    --wa;

     
    *info = 0;

 

    if (*n <= 0 || *tol < zero || *lwa < *n * (*n * 3 + 13) / 2) {
	goto L20;
    }

 

    maxfev = (*n + 1) * 200;
    xtol = *tol;
    ml = *n - 1;
    mu = *n - 1;
    epsfcn = zero;
    mode = 2;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa[j] = one;
 
    }
    nprint = 0;
    lr = *n * (*n + 1) / 2;
    index = *n * 6 + lr;
    hybrd_(fcn, n, &x[1], &fvec[1], &xtol, &maxfev, &ml, &mu, &epsfcn, &wa[1],
	     &mode, &factor, &nprint, info, &nfev, &wa[index + 1], n, &wa[*n *
	     6 + 1], &lr, &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1], &
	    wa[(*n << 2) + 1], &wa[*n * 5 + 1]);
    if (*info == 5) {
	*info = 4;
    }
L20:
    return 0;

 

}  

  int hybrj_(fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag,
	 mode, factor, nprint, info, nfev, njev, r__, lr, qtf, wa1, wa2, wa3, 
	wa4)
  int (*fcn) ();
integer *n;
doublereal *x, *fvec, *fjac;
integer *ldfjac;
doublereal *xtol;
integer *maxfev;
doublereal *diag;
integer *mode;
doublereal *factor;
integer *nprint, *info, *nfev, *njev;
doublereal *r__;
integer *lr;
doublereal *qtf, *wa1, *wa2, *wa3, *wa4;
{
     

    static doublereal one = 1.;
    static doublereal p1 = .1;
    static doublereal p5 = .5;
    static doublereal p001 = .001;
    static doublereal p0001 = 1e-4;
    static doublereal zero = 0.;

     
    integer fjac_dim1, fjac_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    static logical sing;
    static integer iter;
    static doublereal temp;
    static integer i__, j, l, iflag;
    static doublereal delta;
    extern   int qrfac_();
    static logical jeval;
    static integer ncsuc;
    static doublereal ratio;
    extern doublereal enorm_();
    static doublereal fnorm;
    extern   int qform_();
    static doublereal pnorm, xnorm, fnorm1;
    extern   int r1updt_();
    static integer nslow1, nslow2;
    extern doublereal dlamch_();
    extern   int r1mpyq_();
    static integer ncfail;
    extern   int dogleg_();
    static doublereal actred, epsmch, prered;
    static integer jm1, iwa[1];
    static doublereal sum;

 

 
 

 
 

 
 
 

 
 
 

 
 

 
 

 
 
 

 
 

 
 

 

 

 

 
 

 

 
 

 
     
    --wa4;
    --wa3;
    --wa2;
    --wa1;
    --qtf;
    --diag;
    --fvec;
    --x;
    fjac_dim1 = *ldfjac;
    fjac_offset = fjac_dim1 + 1;
    fjac -= fjac_offset;
    --r__;

     

 

    epsmch = dlamch_("p", 1L);

    *info = 0;
    iflag = 0;
    *nfev = 0;
    *njev = 0;

 

    if (*n <= 0 || *ldfjac < *n || *xtol < zero || *maxfev <= 0 || *factor <= 
	    zero || *lr < *n * (*n + 1) / 2) {
	goto L300;
    }
    if (*mode != 2) {
	goto L20;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (diag[j] <= zero) {
	    goto L300;
	}
 
    }
L20:

 
 

    iflag = 1;
    (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag);
    *nfev = 1;
    if (iflag < 0) {
	goto L300;
    }
    fnorm = enorm_(n, &fvec[1]);

 

    iter = 1;
    ncsuc = 0;
    ncfail = 0;
    nslow1 = 0;
    nslow2 = 0;

 

L30:
    jeval = (1) ;

 

    iflag = 2;
    (*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag);
    ++(*njev);
    if (iflag < 0) {
	goto L300;
    }

 

    qrfac_(n, n, &fjac[fjac_offset], ldfjac, &c_false, iwa, &c__1, &wa1[1], &
	    wa2[1], &wa3[1]);

 
 

    if (iter != 1) {
	goto L70;
    }
    if (*mode == 2) {
	goto L50;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	diag[j] = wa2[j];
	if (wa2[j] == zero) {
	    diag[j] = one;
	}
 
    }
L50:

 
 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa3[j] = diag[j] * x[j];
 
    }
    xnorm = enorm_(n, &wa3[1]);
    delta = *factor * xnorm;
    if (delta == zero) {
	delta = *factor;
    }
L70:

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	qtf[i__] = fvec[i__];
 
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (fjac[j + j * fjac_dim1] == zero) {
	    goto L110;
	}
	sum = zero;
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    sum += fjac[i__ + j * fjac_dim1] * qtf[i__];
 
	}
	temp = -sum / fjac[j + j * fjac_dim1];
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    qtf[i__] += fjac[i__ + j * fjac_dim1] * temp;
 
	}
L110:
 
	;
    }

 

    sing = (0) ;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	l = j;
	jm1 = j - 1;
	if (jm1 < 1) {
	    goto L140;
	}
	i__2 = jm1;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    r__[l] = fjac[i__ + j * fjac_dim1];
	    l = l + *n - i__;
 
	}
L140:
	r__[l] = wa1[j];
	if (wa1[j] == zero) {
	    sing = (1) ;
	}
 
    }

 

    qform_(n, n, &fjac[fjac_offset], ldfjac, &wa1[1]);

 

    if (*mode == 2) {
	goto L170;
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
 
	d__1 = diag[j], d__2 = wa2[j];
	diag[j] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    }
L170:

 

L180:

 

    if (*nprint <= 0) {
	goto L190;
    }
    iflag = 0;
    if ((iter - 1) % *nprint == 0) {
	(*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag);
    }
    if (iflag < 0) {
	goto L300;
    }
L190:

 

    dogleg_(n, &r__[1], lr, &diag[1], &qtf[1], &delta, &wa1[1], &wa2[1], &wa3[
	    1]);

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa1[j] = -wa1[j];
	wa2[j] = x[j] + wa1[j];
	wa3[j] = diag[j] * wa1[j];
 
    }
    pnorm = enorm_(n, &wa3[1]);

 

    if (iter == 1) {
	delta = (( delta ) <= ( pnorm ) ? ( delta ) : ( pnorm )) ;
    }

 

    iflag = 1;
    (*fcn)(n, &wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, &iflag);
    ++(*nfev);
    if (iflag < 0) {
	goto L300;
    }
    fnorm1 = enorm_(n, &wa4[1]);

 

    actred = -one;
    if (fnorm1 < fnorm) {
 
	d__1 = fnorm1 / fnorm;
	actred = one - d__1 * d__1;
    }

 

    l = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sum = zero;
	i__2 = *n;
	for (j = i__; j <= i__2; ++j) {
	    sum += r__[l] * wa1[j];
	    ++l;
 
	}
	wa3[i__] = qtf[i__] + sum;
 
    }
    temp = enorm_(n, &wa3[1]);
    prered = zero;
    if (temp < fnorm) {
 
	d__1 = temp / fnorm;
	prered = one - d__1 * d__1;
    }

 
 

    ratio = zero;
    if (prered > zero) {
	ratio = actred / prered;
    }

 

    if (ratio >= p1) {
	goto L230;
    }
    ncsuc = 0;
    ++ncfail;
    delta = p5 * delta;
    goto L240;
L230:
    ncfail = 0;
    ++ncsuc;
    if (ratio >= p5 || ncsuc > 1) {
 
	d__1 = delta, d__2 = pnorm / p5;
	delta = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if ((d__1 = ratio - one, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= p1) {
	delta = pnorm / p5;
    }
L240:

 

    if (ratio < p0001) {
	goto L260;
    }

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	x[j] = wa2[j];
	wa2[j] = diag[j] * x[j];
	fvec[j] = wa4[j];
 
    }
    xnorm = enorm_(n, &wa2[1]);
    fnorm = fnorm1;
    ++iter;
L260:

 

    ++nslow1;
    if (actred >= p001) {
	nslow1 = 0;
    }
    if (jeval) {
	++nslow2;
    }
    if (actred >= p1) {
	nslow2 = 0;
    }

 

    if (delta <= *xtol * xnorm || fnorm == zero) {
	*info = 1;
    }
    if (*info != 0) {
	goto L300;
    }

 

    if (*nfev >= *maxfev) {
	*info = 2;
    }
 
    d__1 = p1 * delta;
    if (p1 * (( d__1 ) >= ( pnorm ) ? ( d__1 ) : ( pnorm ))  <= epsmch * xnorm) {
	*info = 3;
    }
    if (nslow2 == 5) {
	*info = 4;
    }
    if (nslow1 == 10) {
	*info = 5;
    }
    if (*info != 0) {
	goto L300;
    }

 

    if (ncfail == 2) {
	goto L290;
    }

 
 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	sum = zero;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    sum += fjac[i__ + j * fjac_dim1] * wa4[i__];
 
	}
	wa2[j] = (sum - wa3[j]) / pnorm;
	wa1[j] = diag[j] * (diag[j] * wa1[j] / pnorm);
	if (ratio >= p0001) {
	    qtf[j] = sum;
	}
 
    }

 

    r1updt_(n, n, &r__[1], lr, &wa1[1], &wa2[1], &wa3[1], &sing);
    r1mpyq_(n, n, &fjac[fjac_offset], ldfjac, &wa2[1], &wa3[1]);
    r1mpyq_(&c__1, n, &qtf[1], &c__1, &wa2[1], &wa3[1]);

 

    jeval = (0) ;
    goto L180;
L290:

 

    goto L30;
L300:

 

    if (iflag < 0) {
	*info = iflag;
    }
    iflag = 0;
    if (*nprint > 0) {
	(*fcn)(n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag);
    }
    return 0;

 

}  

  int hybrj1_(fcn, n, x, fvec, fjac, ldfjac, tol, info, wa, 
	lwa)
  int (*fcn) ();
integer *n;
doublereal *x, *fvec, *fjac;
integer *ldfjac;
doublereal *tol;
integer *info;
doublereal *wa;
integer *lwa;
{
     

    static doublereal factor = 100.;
    static doublereal one = 1.;
    static doublereal zero = 0.;

     
    integer fjac_dim1, fjac_offset, i__1;

     
    static integer mode, nfev, njev;
    static doublereal xtol;
    static integer j;
    extern   int hybrj_();
    static integer lr, maxfev, nprint;
 
     
    --fvec;
    --x;
    fjac_dim1 = *ldfjac;
    fjac_offset = fjac_dim1 + 1;
    fjac -= fjac_offset;
    --wa;

     
    *info = 0;

 

    if (*n <= 0 || *ldfjac < *n || *tol < zero || *lwa < *n * (*n + 13) / 2) {
	goto L20;
    }

 

    maxfev = (*n + 1) * 100;
    xtol = *tol;
    mode = 2;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	wa[j] = one;
 
    }
    nprint = 0;
    lr = *n * (*n + 1) / 2;
    hybrj_(fcn, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &xtol, &
	    maxfev, &wa[1], &mode, &factor, &nprint, info, &nfev, &njev, &wa[*
	    n * 6 + 1], &lr, &wa[*n + 1], &wa[(*n << 1) + 1], &wa[*n * 3 + 1],
	     &wa[(*n << 2) + 1], &wa[*n * 5 + 1]);
    if (*info == 5) {
	*info = 4;
    }
L20:
    return 0;

 

}  

 
  int icscof_(ico, ntob, nex, nob, yob, ob, cof)
integer *ico, *ntob, *nex, *nob;
doublereal *yob, *ob, *cof;
{
     
    integer yob_dim1, yob_offset, ob_dim1, ob_dim2, ob_offset, cof_dim1, 
	    cof_offset, i__1, i__2, i__3;
    doublereal d__1;

     
    static integer i__, j, k;

 
 
 

 

 
 
 
 

 
 

 

 
 

     
    cof_dim1 = *nob;
    cof_offset = cof_dim1 + 1;
    cof -= cof_offset;
    ob_dim1 = *nex;
    ob_dim2 = *ntob;
    ob_offset = ob_dim1 * (ob_dim2 + 1) + 1;
    ob -= ob_offset;
    yob_dim1 = *nob;
    yob_offset = yob_dim1 + 1;
    yob -= yob_offset;

     
    i__1 = *nob;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *ntob;
	for (j = 1; j <= i__2; ++j) {
 
	    cof[i__ + j * cof_dim1] = 0.;
	}
    }
 
 
 
    if (*ico == 1) {
	i__2 = *nob;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__1 = *ntob;
	    for (j = 1; j <= i__1; ++j) {
		i__3 = *nex;
		for (k = 1; k <= i__3; ++k) {
 
		    cof[i__ + j * cof_dim1] += (d__1 = ob[k + (j + i__ * 
			    ob_dim2) * ob_dim1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		}
	    }
	}
	i__3 = *nob;
	for (i__ = 1; i__ <= i__3; ++i__) {
	    i__1 = *ntob;
	    for (j = 1; j <= i__1; ++j) {
 
		cof[i__ + j * cof_dim1] = (doublereal) (*nex) / cof[i__ + j * 
			cof_dim1];
	    }
	}
 
 
 

    } else {
	i__1 = *nob;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__3 = *ntob;
	    for (j = 1; j <= i__3; ++j) {
		i__2 = *nex;
		for (k = 1; k <= i__2; ++k) {
 
 
		    d__1 = yob[i__ + j * yob_dim1] - ob[k + (j + i__ * 
			    ob_dim2) * ob_dim1];
		    cof[i__ + j * cof_dim1] += d__1 * d__1;
		}
	    }
	}
	i__2 = *nob;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = *ntob;
	    for (j = 1; j <= i__3; ++j) {
 
		cof[i__ + j * cof_dim1] = .5 / cof[i__ + j * cof_dim1];
	    }
	}
    }
    return 0;
}  

  int icse_(ind, nu, u, co, g, itv, rtv, dtv, icsef, icsec2, 
	icsei)
integer *ind, *nu;
doublereal *u, *co, *g;
integer *itv;
real *rtv;
doublereal *dtv;
  int (*icsef) (), (*icsec2) (), (*icsei) ();
{
     
    static char fmt_8003[] = "(1x,\002icse : taille des tableaux itv,dtv insuffisante\002,/,8x,\002valeurs minimales \002,i6,2x,i6)";

     
    integer i__1, i__2;

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static integer lech, lcof, indi, lobs, ltob, ldmy, lyob, ldtu, litu, mdtv,
	     mitv, lsmy, ldif1, ldif2, ldif3;
    extern   int icse1_(), icse2_();
    static integer lipv1, lipv2, mdtv1, mdtv2, mitv1, mitv2, i__, ludep, 
	    litob, loldp, lyold, lytob, ldtvt, lyerr, lyint, litvt, lytot, lb,
	     ld, lf, lp, ly, lsmold, loldmu, lp0, ly0, lob, ldm, lfu, lui, 
	    nui, lfy, lgt, lc2y, ly0u;

     
    static cilist io___2339 = { 0, 6, 0, fmt_8003, 0 };
 
     
    --g;
    --u;
    --itv;
    --rtv;
    --dtv;

     
    if ((icsez_._1) .iu[1] > 0) {
 
	i__1 = *nu, i__2 = (icsez_._1) .nuc + 1;
	lui = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    }
    if ((icsez_._1) .iu[0] > 0) {
	lui = 1;
    }
    nui = (icsez_._1) .iu[0] * (icsez_._1) .nuc + (icsez_._1) .iu[1] * (icsez_._1) .nuv * (
	    (icsez_._1) .nti + (icsez_._1) .ntf + 1);

 
 
 
 
 

    litu = 1;
    litvt = litu + (icsez_._1) .nitu;

 
 
 
 
 

    ldtu = 1;
    ly0 = ldtu + (icsez_._1) .ndtu;
    ltob = ly0 + (icsez_._1) .ny;
    lobs = ltob + (icsez_._1) .ntob;
    lob = lobs + (icsez_._1) .nob * (icsez_._1) .ny;
    lech = lob + (icsez_._1) .nex * (icsez_._1) .ntob * (icsez_._1) .nob;
    lcof = lech + *nu;
 
    lb = lcof + (icsez_._1) .nob * (icsez_._1) .ntob;
    lfy = lb + (icsez_._1) .ny;
    lfu = lfy + (icsez_._1) .ny * (icsez_._1) .ny;
    ludep = lfu + (icsez_._1) .ny * ((icsez_._1) .nuc + (icsez_._1) .nuv);
    lytot = ludep + *nu;
    lf = lytot + (icsez_._1) .ny * ((icsez_._1) .nti + (icsez_._1) .ntf);
    ldtvt = lf + (icsez_._1) .ny;

 

    lipv1 = litvt;
    mitv1 = lipv1 + (icsez_._1) .ny - 1;

 

    litob = litvt;
    lipv2 = litob + (icsez_._1) .ntob;
    mitv2 = lipv2 + (icsez_._1) .ny - 1;

    mitv = (( mitv1 ) >= ( mitv2 ) ? ( mitv1 ) : ( mitv2 )) ;

 

    ldm = ldtvt;
    lyold = ldm + (icsez_._1) .ny * (icsez_._1) .ny;
    lsmold = lyold + (icsez_._1) .ny;
    lyint = lsmold + (icsez_._1) .ny;
    lyerr = lyint + (icsez_._1) .ny;
    ldif1 = lyerr + (icsez_._1) .ny;
    ldif2 = ldif1 + (icsez_._1) .ny;
    ldif3 = ldif2 + (icsez_._1) .ny;
    mdtv1 = ldif3 + (icsez_._1) .ny - 1;

 

    lytob = ldtvt;
    lc2y = lytob + (icsez_._1) .ny * (icsez_._1) .ntob;
    ly0u = lc2y + (icsez_._1) .ny * (icsez_._1) .ntob;
    ldmy = ly0u + (icsez_._1) .ny * *nu;
    lsmy = ldmy + (icsez_._1) .ny * (icsez_._1) .ny;
    loldmu = lsmy + (icsez_._1) .ny * (icsez_._1) .ny;
    ly = loldmu + (icsez_._1) .ny * ((icsez_._1) .nuc + (icsez_._1) .nuv);
    loldp = ly + (icsez_._1) .ny;
    lp = loldp + (icsez_._1) .ny;
    lp0 = lp + (icsez_._1) .ny;
    lgt = lp0 + (icsez_._1) .ny;
 
    i__1 = (icsez_._1) .nuc + (icsez_._1) .nuv;
    lyob = lgt + (( i__1 ) >= ( nui ) ? ( i__1 ) : ( nui )) ;
    ld = lyob + (icsez_._1) .nob * (icsez_._1) .ntob;
    mdtv2 = ld + (icsez_._1) .nob - 1;

    mdtv = (( mdtv1 ) >= ( mdtv2 ) ? ( mdtv1 ) : ( mdtv2 )) ;
    if (mitv > (nird_._1) .nitv || mdtv > (nird_._1) .ndtv) {
	if ((nird_._1) .nitv + (nird_._1) .ndtv > 0) {
	    s_wsfe(&io___2339);
	    do_fio(&c__1, (char *)&mitv, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&mdtv, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	(nird_._1) .nitv = mitv;
	(nird_._1) .ndtv = mdtv;
	return 0;
    }
    i__1 = *nu;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dtv[ludep + i__ - 1] = u[i__];
	u[i__] = dtv[lech + i__ - 1] * u[i__];
 
    }

 

    if ((icsez_._1) .iu[0] > 0) {
	indi = 1;
	(*icsei)(&indi, &nui, &u[lui], &dtv[ly0], &dtv[ly0u], &itv[litu], &
		dtv[ldtu], & (icsez_._1) .t0, & (icsez_._1) .tf, & (icsez_._1) .dti, &
		(icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu, & (icsez_._1) .nuc, &
		(icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, & (icsez_._1) .ntf, &
		(icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, & (icsez_._1) .nex, &
		(icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, & (icsez_._1) .nitu, &
		(icsez_._1) .ndtu);
	if (indi <= 0) {
	    *ind = indi;
	    return 0;
	}
    }

 
 
 
 
 
 

 

 
 

 
 

 
 

 
 

 
 

 
 

 
 

 
 

    icse1_(ind, nu, &u[1], icsef, &dtv[ly0], &dtv[lytot], &dtv[lf], &dtv[lb], 
	    &dtv[lfy], &dtv[lfu], &itv[lipv1], &dtv[ldm], &dtv[lyold], &dtv[
	    lsmold], &dtv[lyint], &dtv[lyerr], &dtv[ldif1], &dtv[ldif2], &dtv[
	    ldif3], &itv[litu], &dtv[ldtu], & (icsez_._1) .t0, & (icsez_._1) .tf, &
	    (icsez_._1) .dti, & (icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu, &
	    (icsez_._1) .nuc, & (icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, &
	    (icsez_._1) .ntf, & (icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, &
	    (icsez_._1) .nex, & (icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, &
	    (icsez_._1) .nitu, & (icsez_._1) .ndtu);

    if (*ind <= 0) {
	return 0;
    }


    icse2_(ind, nu, &u[1], co, &g[1], icsef, icsec2, icsei, &dtv[ly0], &dtv[
	    ltob], &dtv[lobs], &dtv[lob], &dtv[lytot], &dtv[lf], &dtv[lb], &
	    dtv[lfy], &dtv[lfu], &itv[lipv2], &itv[litob], &dtv[lcof], &dtv[
	    lytob], &dtv[lc2y], &dtv[ly0u], &dtv[ldmy], &dtv[lsmy], &dtv[
	    loldmu], &dtv[ly], &dtv[loldp], &dtv[lp], &dtv[lp0], &dtv[lgt], &
	    dtv[lyob], &dtv[ld], &itv[litu], &dtv[ldtu], & (icsez_._1) .t0, &
	    (icsez_._1) .tf, & (icsez_._1) .dti, & (icsez_._1) .dtf, & (icsez_._1) .ermx, (icsez_._1) .iu,
	     & (icsez_._1) .nuc, & (icsez_._1) .nuv, & (icsez_._1) .ilin, & (icsez_._1) .nti, &
	    (icsez_._1) .ntf, & (icsez_._1) .ny, & (icsez_._1) .nea, & (icsez_._1) .itmx, &
	    (icsez_._1) .nex, & (icsez_._1) .nob, & (icsez_._1) .ntob, & (icsez_._1) .ntobi, &
	    (icsez_._1) .nitu, & (icsez_._1) .ndtu);
    i__1 = *nu;
    for (i__ = 1; i__ <= i__1; ++i__) {
	g[i__] = dtv[lech + i__ - 1] * g[i__];
	u[i__] = dtv[ludep + i__ - 1];
 
    }
    return 0;

 


 

}  

  int icse0_(nu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, 
	nti, ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nitv, 
	nrtv, ndtv)
integer *nu;
doublereal *t0, *tf, *dti, *dtf, *ermx;
integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, *
	ntob, *ntobi, *nitu, *ndtu, *nitv, *nrtv, *ndtv;
{
    extern   int icse_();
    static integer i__;
    static doublereal zz;
    static integer ind;


 
 


     
    --iu;

     
    (icsez_._2) .t00 = *t0;
    (icsez_._2) .tf0 = *tf;
    (icsez_._2) .dti0 = *dti;
    (icsez_._2) .dtf0 = *dtf;
    (icsez_._2) .ermx0 = *ermx;
    for (i__ = 1; i__ <= 5; ++i__) {
 
	(icsez_._2) .iu0[i__ - 1] = iu[i__];
    }
    (icsez_._2) .nuc0 = *nuc;
    (icsez_._2) .nuv0 = *nuv;
    (icsez_._2) .ilin0 = *ilin;
    (icsez_._2) .nti0 = *nti;
    (icsez_._2) .ntf0 = *ntf;
    (icsez_._2) .ny0 = *ny;
    (icsez_._2) .nea0 = *nea;
    (icsez_._2) .itmx0 = *itmx;
    (icsez_._2) .nex0 = *nex;
    (icsez_._2) .nob0 = *nob;
    (icsez_._2) .ntob0 = *ntob;
    (icsez_._2) .ntobi0 = *ntobi;
    (icsez_._2) .nitu0 = *nitu;
    (icsez_._2) .ndtu0 = *ndtu;
    (nird_._2) .nitv0 = 0;
    (nird_._2) .nrtv0 = 0;
    (nird_._2) .ndtv0 = 0;
    ind = 0;
    icse_(&ind, nu, &zz, &zz, &zz, &zz, &zz, &zz, &zz, &zz, &zz);
    *nitv = (( 1 ) >= ( (nird_._2) .nitv0 ) ? ( 1 ) : ( (nird_._2) .nitv0 )) ;
    *nrtv = (( 1 ) >= ( (nird_._2) .nrtv0 ) ? ( 1 ) : ( (nird_._2) .nrtv0 )) ;
    *ndtv = (( 1 ) >= ( (nird_._2) .ndtv0 ) ? ( 1 ) : ( (nird_._2) .ndtv0 )) ;
    return 0;
}  

 
  int icse1_(ind, nu, u, icsef, y0, ytot, f, b, fy, fu, ipv1, 
	dm, yold, smold, yint, yerr, dif1, dif2, dif3, itu, dtu, t0, tf, dti, 
	dtf, ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, 
	ntob, ntobi, nitu, ndtu)
integer *ind, *nu;
doublereal *u;
  int (*icsef) ();
doublereal *y0, *ytot, *f, *b, *fy, *fu;
integer *ipv1;
doublereal *dm, *yold, *smold, *yint, *yerr, *dif1, *dif2, *dif3;
integer *itu;
doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx;
integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, *
	ntob, *ntobi, *nitu, *ndtu;
{
     
    integer ytot_dim1, ytot_offset, fy_dim1, fy_offset, fu_dim1, fu_offset, 
	    dm_dim1, dm_offset, i__1, i__2, i__3;
    doublereal d__1;

     
    integer s_wsle(), do_lio(), e_wsle();

     
    static integer indf, info;
    static doublereal told;
    extern doublereal dnrm2_();
    extern   int dgefa_();
    static integer i__, j;
    static doublereal t;
    extern   int dscal_(), dgesl_(), dcopy_();
    static doublereal dtinv;
    extern   int daxpy_();
    static doublereal dt;
    static integer it, kt;
    static doublereal err;
    static integer luv;
    extern   int dadd_();

     
    static cilist io___2357 = { 0, 6, 0, 0, 0 };



 


 

     
    --u;
    --iu;
    --dif3;
    --dif2;
    --dif1;
    --yerr;
    --yint;
    --smold;
    --yold;
    dm_dim1 = *ny;
    dm_offset = dm_dim1 + 1;
    dm -= dm_offset;
    --ipv1;
    fu_dim1 = *ny;
    fu_offset = fu_dim1 + 1;
    fu -= fu_offset;
    fy_dim1 = *ny;
    fy_offset = fy_dim1 + 1;
    fy -= fy_offset;
    --b;
    --f;
    ytot_dim1 = *ny;
    ytot_offset = ytot_dim1 + 1;
    ytot -= ytot_offset;
    --y0;
    --itu;
    --dtu;

     
    t = *t0;
    dcopy_(ny, &y0[1], &c__1, &yold[1], &c__1);

 
 

    i__1 = *nti + *ntf;
    for (kt = 1; kt <= i__1; ++kt) {

 
 
 
 
 
 
 

 
 
 

 

 
	i__2 = *nu, i__3 = *nuc + 1 + (kt - 1) * *nuv;
	luv = (( i__2 ) <= ( i__3 ) ? ( i__2 ) : ( i__3 )) ;
	told = t;

 

	if (kt <= *nti) {
	    t = kt * *dti + *t0;
	    dt = *dti;
	} else {
	    t = *nti * *dti + (kt - *nti) * *dtf + *t0;
	    dt = *dtf;
	}
	dtinv = 1. / dt;

 
 
 

 
 
 
 

	if (kt == 1 || kt == *nti + 1 || *ilin <= 1) {
	    indf = 2;
	    if (kt == 1 || *ilin <= 1) {
		(*icsef)(&indf, &told, &yold[1], &u[1], &u[luv], &f[1], &fy[
			fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], 
			t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, 
			ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu)
			;
	    }
	    if (indf <= 0) {
		*ind = indf;
		return 0;
	    }
	    i__2 = *ny;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		i__3 = *ny;
		for (j = 1; j <= i__3; ++j) {
 
		    dm[i__ + j * dm_dim1] = -fy[i__ + j * fy_dim1] / 2.;
		}
	    }
	    i__3 = *ny;
	    for (i__ = *nea + 1; i__ <= i__3; ++i__) {
 
		dm[i__ + i__ * dm_dim1] += dtinv;
	    }
	    dgefa_(&dm[dm_offset], ny, ny, &ipv1[1], &info);
	}

 
 

	it = 1;

 
 
 
 
 

 
 
 

	if (kt == 1) {
	    indf = 1;
	    (*icsef)(&indf, &told, &yold[1], &u[1], &u[luv], &smold[1], &fy[
		    fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, 
		    tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, 
		    nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu);
	    if (indf <= 0) {
		*ind = indf;
		return 0;
	    }
	}

 

	if (*nea > 0) {
	    i__3 = *nea;
	    for (i__ = 1; i__ <= i__3; ++i__) {
 
		smold[i__] = 0.;
	    }
	}
	dcopy_(ny, &smold[1], &c__1, &dif1[1], &c__1);
	dscal_(ny, &dt, &dif1[1], &c__1);

 

 

 
	i__3 = *nu, i__2 = *nuc + 1 + kt * *nuv;
	luv = (( i__3 ) <= ( i__2 ) ? ( i__3 ) : ( i__2 )) ;
	dcopy_(ny, &yold[1], &c__1, &yint[1], &c__1);
	dadd_(ny, &dif1[1], &c__1, &yint[1], &c__1);
	indf = 1;
	(*icsef)(&indf, &t, &yint[1], &u[1], &u[luv], &dif2[1], &fy[fy_offset]
		, &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, 
		ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, 
		nob, ntob, ntobi, nitu, ndtu);
	if (indf <= 0) {
	    *ind = indf;
	    return 0;
	}

 

	dadd_(ny, &smold[1], &c__1, &dif2[1], &c__1);
	dscal_(ny, &c_b806, &dif2[1], &c__1);

 

	d__1 = -dtinv;
	daxpy_(ny, &d__1, &dif1[1], &c__1, &dif2[1], &c__1);

 
 

	dcopy_(ny, &dif1[1], &c__1, &dif3[1], &c__1);

 

L50:
	dgesl_(&dm[dm_offset], ny, ny, &ipv1[1], &dif2[1], &c__0);

 

	dadd_(ny, &dif2[1], &c__1, &dif3[1], &c__1);

 
 
 
 

 

	dcopy_(ny, &yold[1], &c__1, &yerr[1], &c__1);
	dadd_(ny, &dif3[1], &c__1, &yerr[1], &c__1);

 
 
 
	if (*ermx < 0.) {
	    goto L55;
	}

	indf = 1;
	(*icsef)(&indf, &t, &yerr[1], &u[1], &u[luv], &dif1[1], &fy[fy_offset]
		, &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, 
		ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, 
		nob, ntob, ntobi, nitu, ndtu);
	if (indf <= 0) {
	    *ind = indf;
	    return 0;
	}

 

	dcopy_(ny, &dif1[1], &c__1, &dif2[1], &c__1);

 

	dadd_(ny, &smold[1], &c__1, &dif2[1], &c__1);
	dscal_(ny, &c_b806, &dif2[1], &c__1);

 

	i__3 = *ny - *nea;
	d__1 = -dtinv;
	daxpy_(&i__3, &d__1, &dif3[*nea + 1], &c__1, &dif2[*nea + 1], &c__1);

 

	err = dnrm2_(ny, &dif2[1], &c__1);

 
 

	if (err > *ermx && *ilin == 0) {
	    ++it;
	    if (it > *itmx) {
		*ind = -1;
		s_wsle(&io___2357);
		do_lio(&c__9, &c__1, " icse : integration de l etat impossible", 40L);
		e_wsle();
		return 0;
	    }
	    goto L50;
	}

 
 
 

L55:
	dcopy_(ny, &yerr[1], &c__1, &yold[1], &c__1);
	dcopy_(ny, &yold[1], &c__1, &ytot[kt * ytot_dim1 + 1], &c__1);

 
 
 

	dcopy_(ny, &dif1[1], &c__1, &smold[1], &c__1);

 

 
    }
    return 0;
}  

 
  int icse2_(ind, nu, u, co, g, icsef, icsec2, icsei, y0, tob, 
	obs, ob, ytot, f, b, fy, fu, ipv2, itob, cof, ytob, c2y, y0u, dmy, 
	smy, oldmu, y, oldp, p, p0, gt, yob, d__, itu, dtu, t0, tf, dti, dtf, 
	ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, 
	ntobi, nitu, ndtu, nomf, nomc, nomi, nomf_len, nomc_len, nomi_len)
integer *ind, *nu;
doublereal *u, *co, *g;
  int (*icsef) (), (*icsec2) (), (*icsei) ();
doublereal *y0, *tob, *obs, *ob, *ytot, *f, *b, *fy, *fu;
integer *ipv2, *itob;
doublereal *cof, *ytob, *c2y, *y0u, *dmy, *smy, *oldmu, *y, *oldp, *p, *p0, *
	gt, *yob, *d__;
integer *itu;
doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx;
integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, *
	ntob, *ntobi, *nitu, *ndtu;
char *nomf, *nomc, *nomi;
ftnlen nomf_len;
ftnlen nomc_len;
ftnlen nomi_len;
{
     
    integer obs_dim1, obs_offset, ob_dim1, ob_dim2, ob_offset, ytot_dim1, 
	    ytot_offset, fy_dim1, fy_offset, fu_dim1, fu_offset, cof_dim1, 
	    cof_offset, ytob_dim1, ytob_offset, c2y_dim1, c2y_offset, 
	    y0u_dim1, y0u_offset, dmy_dim1, dmy_offset, smy_dim1, smy_offset, 
	    oldmu_dim1, oldmu_offset, yob_dim1, yob_offset, i__1, i__2;

     
    static integer indc, indf, indi;
    extern   int dset_();
    static integer ktob, info;
    extern   int dgefa_();
    static integer i__, j;
    static doublereal t;
    extern   int dscal_(), dgesl_(), dcopy_(), dmmul_();
    static doublereal dt2new, dt;
    static integer kt;
    static doublereal dt2;
    static integer lui, nui, luv;
    extern   int dadd_();


 
 



 

     
    --gt;
    --g;
    --u;
    --iu;
    --p0;
    --p;
    --oldp;
    --y;
    oldmu_dim1 = *ny;
    oldmu_offset = oldmu_dim1 + 1;
    oldmu -= oldmu_offset;
    smy_dim1 = *ny;
    smy_offset = smy_dim1 + 1;
    smy -= smy_offset;
    dmy_dim1 = *ny;
    dmy_offset = dmy_dim1 + 1;
    dmy -= dmy_offset;
    y0u_dim1 = *ny;
    y0u_offset = y0u_dim1 + 1;
    y0u -= y0u_offset;
    --ipv2;
    fu_dim1 = *ny;
    fu_offset = fu_dim1 + 1;
    fu -= fu_offset;
    fy_dim1 = *ny;
    fy_offset = fy_dim1 + 1;
    fy -= fy_offset;
    --b;
    --f;
    ytot_dim1 = *ny;
    ytot_offset = ytot_dim1 + 1;
    ytot -= ytot_offset;
    --y0;
    --d__;
    obs_dim1 = *nob;
    obs_offset = obs_dim1 + 1;
    obs -= obs_offset;
    yob_dim1 = *nob;
    yob_offset = yob_dim1 + 1;
    yob -= yob_offset;
    c2y_dim1 = *ny;
    c2y_offset = c2y_dim1 + 1;
    c2y -= c2y_offset;
    ytob_dim1 = *ny;
    ytob_offset = ytob_dim1 + 1;
    ytob -= ytob_offset;
    cof_dim1 = *nob;
    cof_offset = cof_dim1 + 1;
    cof -= cof_offset;
    --itob;
    ob_dim1 = *nex;
    ob_dim2 = *ntob;
    ob_offset = ob_dim1 * (ob_dim2 + 1) + 1;
    ob -= ob_offset;
    --tob;
    --itu;
    --dtu;

     
    dset_(nu, &c_b61, &g[1], &c__1);
    dset_(ny, &c_b61, &p[1], &c__1);
    kt = *nti + *ntf;
    ktob = *ntob;
 
    if (iu[2] > 0) {
 
	i__1 = *nu, i__2 = *nuc + 1;
	lui = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    }
    if (iu[1] > 0) {
	lui = 1;
    }
    nui = iu[1] * *nuc + iu[2] * *nuv * (*nti + *ntf + 1);


 
 
 

    i__1 = *ntobi;
    for (j = 1; j <= i__1; ++j) {
 
	itob[j] = (integer) ((tob[j] - *t0) / *dti + .5);
    }
    if (*ntobi < *ntob) {
	itob[*ntobi + 1] = *nti + (integer) ((tob[*ntobi + 1] - *t0 - *nti * *
		dti) / *dtf + .5);
    }
    if (*ntobi + 1 < *ntob) {
	i__1 = *ntob;
	for (j = *ntobi + 2; j <= i__1; ++j) {
 
	    itob[j] = itob[*ntobi + 1] + (integer) ((tob[j] - tob[*ntobi + 1])
		     / *dtf + .5);
	}
    }

 
 

    i__1 = *ntob;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *ny;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    dcopy_(ny, &ytot[itob[j] * ytot_dim1 + 1], &c__1, &ytob[j * 
		    ytob_dim1 + 1], &c__1);
	}
    }

 
 
 

    if (*ind != 3) {
	indc = 1;
	(*icsec2)(&indc, nu, &tob[1], &obs[obs_offset], &cof[cof_offset], &
		ytob[ytob_offset], &ob[ob_offset], &u[1], co, &c2y[c2y_offset]
		, &g[1], &yob[yob_offset], &d__[1], &itu[1], &dtu[1], t0, tf, 
		dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, 
		itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L,
		 6L, 6L);
	if (indc <= 0) {
	    *ind = indc;
	    return 0;
	}
    }
    if (*ind == 2) {
	return 0;
    }

 
 
 
 

    indc = 2;
    (*icsec2)(&indc, nu, &tob[1], &obs[obs_offset], &cof[cof_offset], &ytob[
	    ytob_offset], &ob[ob_offset], &u[1], co, &c2y[c2y_offset], &g[1], 
	    &yob[yob_offset], &d__[1], &itu[1], &dtu[1], t0, tf, dti, dtf, 
	    ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, 
	    ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L);
    if (indc <= 0) {
	*ind = indc;
	return 0;
    }

 
 

    for (kt = *nti + *ntf; kt >= 1; --kt) {

 
 
 
 
 
 
 

 
 
 
 
 
 

 

 

 

	dcopy_(ny, &p[1], &c__1, &oldp[1], &c__1);
 
	i__2 = *nu, i__1 = *nuc + 1 + kt * *nuv;
	luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ;

 
 

	dcopy_(ny, &ytot[kt * ytot_dim1 + 1], &c__1, &y[1], &c__1);

	if (kt < *nti) {
	    t = kt * *dti + *t0;
	    dt = *dti;
	} else {
	    t = *nti * *dti + (kt - *nti) * *dtf + *t0;
	    dt = *dtf;
	}
	dt2 = dt / 2.;
	if (kt != *nti) {
	    dt2new = dt2;
	} else {
	    dt2new = *dti / 2.;
	}

 
 
 
 


	if (*ilin <= 1) {
	    indf = 2;
	    (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], 
		    &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf,
		     ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, 
		    nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 
		    6L, 6L);
	    if (indf <= 0) {
		*ind = indf;
		return 0;
	    }
	}

	if (kt != *nti + *ntf) {
	    if (*ilin <= 1 || kt == *nti + *ntf - 1 || kt == *nti - 1) {
		i__2 = *ny;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    i__1 = *ny;
		    for (j = 1; j <= i__1; ++j) {
 
			smy[i__ + j * smy_dim1] = dt2 * fy[i__ + j * fy_dim1];
		    }
		}
		i__1 = *ny;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    smy[i__ + i__ * smy_dim1] += 1.;
		}
	    }

 

	    if (*nea > 0) {
		i__1 = *nea;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    p[i__] = 0.;
		}
	    }
	    dmmul_(&p[1], &c__1, &smy[smy_offset], ny, &p0[1], &c__1, &c__1, 
		    ny, ny);

	    dcopy_(ny, &p0[1], &c__1, &p[1], &c__1);
	}

 
 


	if (ktob > 0) {
	    if (kt == itob[ktob]) {
		i__1 = *ny;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    p[i__] += c2y[i__ + ktob * c2y_dim1];
		}
		--ktob;
	    }
	}

 
 
 
 
 
 
 
 
 
 

	if (*ilin <= 1 || kt == *nti + *ntf || kt == *nti) {
	    i__1 = *ny;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		i__2 = *ny;
		for (j = 1; j <= i__2; ++j) {
 
		    dmy[i__ + j * dmy_dim1] = -dt2new * fy[i__ + j * fy_dim1];
		}
	    }
	    i__2 = *ny;
	    for (i__ = *nea + 1; i__ <= i__2; ++i__) {
 
		dmy[i__ + i__ * dmy_dim1] += 1.;
	    }
	    dgefa_(&dmy[dmy_offset], ny, ny, &ipv2[1], &info);
	}

 
 

	dgesl_(&dmy[dmy_offset], ny, ny, &ipv2[1], &p[1], &c__1);

 
 
 

 
 
 

	if (*nuv > 0 || iu[3] == 1) {
	    indf = 3;
	    (*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], 
		    &fu[fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf,
		     ermx, &iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, 
		    nex, nob, ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 
		    6L, 6L);
	    if (indf <= 0) {
		*ind = indf;
		return 0;
	    }
	    if (kt < *nti + *ntf) {
		i__2 = *nuc + *nuv;
		dmmul_(&oldp[1], &c__1, &oldmu[oldmu_offset], ny, &gt[1], &
			c__1, &c__1, ny, &i__2);
		i__2 = *nuc + *nuv;
		dscal_(&i__2, &dt2, &gt[1], &c__1);
 
		if (iu[3] > 0) {
		    dadd_(nuc, &gt[1], &c__1, &g[1], &c__1);
		}
		if (*nuv > 0) {
 
		    i__2 = *nu, i__1 = *nuc + 1 + (kt + 1) * *nuv;
		    luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ;
		    dadd_(nuv, &gt[*nuc + 1], &c__1, &g[luv], &c__1);
		}
		if (*nea > 0) {
		    i__2 = *nea;
		    for (i__ = 1; i__ <= i__2; ++i__) {
 
			oldp[i__] = 0.;
		    }
		}
		i__2 = *nuc + *nuv;
		dmmul_(&oldp[1], &c__1, &fu[fu_offset], ny, &gt[1], &c__1, &
			c__1, ny, &i__2);
		i__2 = *nuc + *nuv;
		dscal_(&i__2, &dt2, &gt[1], &c__1);
 
		if (iu[3] > 0) {
		    dadd_(nuc, &gt[1], &c__1, &g[1], &c__1);
		}
		if (*nuv > 0) {
 
		    i__2 = *nu, i__1 = *nuc + 1 + kt * *nuv;
		    luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ;
		    dadd_(nuv, &gt[*nuc + 1], &c__1, &g[luv], &c__1);
		}
	    }

 

	    i__2 = *ny * (*nuc + *nuv);
	    dcopy_(&i__2, &fu[fu_offset], &c__1, &oldmu[oldmu_offset], &c__1);

 

 

 
 
 

	    if (kt == 1) {
		t = *t0;
		dt2 = *dti / 2.;
		dcopy_(ny, &y0[1], &c__1, &y[1], &c__1);
		indf = 3;
		(*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[
			fy_offset], &fu[fu_offset], &b[1], &itu[1], &dtu[1], 
			t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, 
			ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu,
			 nomf, nomc, nomi, 6L, 6L, 6L);
		if (indf <= 0) {
		    *ind = indf;
		    return 0;
		}
		i__2 = *nuc + *nuv;
		dmmul_(&p[1], &c__1, &oldmu[oldmu_offset], ny, &gt[1], &c__1, 
			&c__1, ny, &i__2);
		i__2 = *nuc + *nuv;
		dscal_(&i__2, &dt2, &gt[1], &c__1);
 
		if (iu[3] > 0) {
		    dadd_(nuc, &gt[1], &c__1, &g[1], &c__1);
		}
		if (*nuv > 0) {
 
		    i__2 = *nu, i__1 = *nuc + 1 + *nuv;
		    luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ;
		    dadd_(nuv, &gt[*nuc + 1], &c__1, &g[luv], &c__1);
		}
		if (*nea > 0) {
		    i__2 = *nea;
		    for (i__ = 1; i__ <= i__2; ++i__) {
 
			p[i__] = 0.;
		    }
		}
		i__2 = *nuc + *nuv;
		dmmul_(&p[1], &c__1, &fu[fu_offset], ny, &gt[1], &c__1, &c__1,
			 ny, &i__2);
		i__2 = *nuc + *nuv;
		dscal_(&i__2, &dt2, &gt[1], &c__1);
 
		if (iu[3] > 0) {
		    dadd_(nuc, &gt[1], &c__1, &g[1], &c__1);
		}
		if (*nuv > 0) {
 
		    i__2 = *nu, i__1 = *nuc + 1;
		    luv = (( i__2 ) <= ( i__1 ) ? ( i__2 ) : ( i__1 )) ;
		    dadd_(nuv, &gt[*nuc + 1], &c__1, &g[luv], &c__1);
		}
	    }
	}
 
    }

 

    if ((( iu[1] ) >= ( iu[2] ) ? ( iu[1] ) : ( iu[2] ))  > 0) {

 

	indf = 2;
	(*icsef)(&indf, &t, &y[1], &u[1], &u[luv], &f[1], &fy[fy_offset], &fu[
		fu_offset], &b[1], &itu[1], &dtu[1], t0, tf, dti, dtf, ermx, &
		iu[1], nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, 
		ntob, ntobi, nitu, ndtu, nomf, nomc, nomi, 6L, 6L, 6L);
	if (indf == 0) {
	    *ind = indf;
	    return 0;
	}
	i__2 = *ny;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__1 = *ny;
	    for (j = 1; j <= i__1; ++j) {
 
		smy[i__ + j * smy_dim1] = dt2 * fy[i__ + j * fy_dim1];
	    }
	}
	i__1 = *ny;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    smy[i__ + i__ * smy_dim1] += 1.;
	}
	if (*nea > 0) {
	    i__1 = *nea;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		p[i__] = 0.;
	    }
	}
	dmmul_(&p[1], &c__1, &smy[smy_offset], ny, &p0[1], &c__1, &c__1, ny, 
		ny);
 
	indi = 2;
	(*icsei)(&indi, &nui, &u[lui], &y0[1], &y0u[y0u_offset], &itu[1], &
		dtu[1], t0, tf, dti, dtf, ermx, &iu[1], nuc, nuv, ilin, nti, 
		ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu, nomf, 
		nomc, nomi, 6L, 6L, 6L);
	if (indi <= 0) {
	    *ind = indi;
	    return 0;
	}
	dmmul_(&p0[1], &c__1, &y0u[y0u_offset], ny, &gt[1], &c__1, &c__1, &
		nui, &nui);
	i__1 = nui;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    g[lui + i__ - 1] += gt[i__];
	}

    }
}  

  int icsec2_(indc, nu, tob, obs, cof, ytob, ob, u, c__, cy, g,
	 yob, d__, itu, dtu, t0, tf, dti, dtf, ermx, iu, nuc, nuv, ilin, nti, 
	ntf, ny, nea, itmx, nex, nob, ntob, ntobi, nitu, ndtu)
integer *indc, *nu;
doublereal *tob, *obs, *cof, *ytob, *ob, *u, *c__, *cy, *g, *yob, *d__;
integer *itu;
doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx;
integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, *
	ntob, *ntobi, *nitu, *ndtu;
{
     
    integer obs_dim1, obs_offset, cof_dim1, cof_offset, ytob_dim1, 
	    ytob_offset, ob_dim1, ob_dim2, ob_offset, cy_dim1, cy_offset, 
	    yob_dim1, yob_offset, i__1, i__2, i__3;
    doublereal d__1;

     
    static integer i__, j, k;
    extern   int dmmul_();



 


 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 

     
    --g;
    --u;
    --iu;
    --d__;
    obs_dim1 = *nob;
    obs_offset = obs_dim1 + 1;
    obs -= obs_offset;
    yob_dim1 = *nob;
    yob_offset = yob_dim1 + 1;
    yob -= yob_offset;
    cy_dim1 = *ny;
    cy_offset = cy_dim1 + 1;
    cy -= cy_offset;
    ob_dim1 = *nex;
    ob_dim2 = *ntob;
    ob_offset = ob_dim1 * (ob_dim2 + 1) + 1;
    ob -= ob_offset;
    ytob_dim1 = *ny;
    ytob_offset = ytob_dim1 + 1;
    ytob -= ytob_offset;
    cof_dim1 = *nob;
    cof_offset = cof_dim1 + 1;
    cof -= cof_offset;
    --tob;
    --itu;
    --dtu;

     
    dmmul_(&obs[obs_offset], nob, &ytob[ytob_offset], ny, &yob[yob_offset], 
	    nob, nob, ny, ntob);
    if (*indc == 1) {
	*c__ = 0.;
	i__1 = *nob;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *ntob;
	    for (j = 1; j <= i__2; ++j) {
		i__3 = *nex;
		for (k = 1; k <= i__3; ++k) {
 
		    d__1 = yob[i__ + j * yob_dim1] - ob[k + (j + i__ * 
			    ob_dim2) * ob_dim1];
		    *c__ += cof[i__ + j * cof_dim1] * .5 * (d__1 * d__1);
 
		}
 
	    }
 
	}
    } else {
	i__1 = *ntob;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *nob;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		d__[i__] = 0.;
		i__3 = *nex;
		for (k = 1; k <= i__3; ++k) {
		    d__[i__] += cof[i__ + j * cof_dim1] * (yob[i__ + j * 
			    yob_dim1] - ob[k + (j + i__ * ob_dim2) * ob_dim1])
			    ;
 
		}
 
	    }
	    dmmul_(&d__[1], &c__1, &obs[obs_offset], nob, &cy[j * cy_dim1 + 1]
		    , &c__1, &c__1, nob, ny);
 
	}
    }
}  

  int icsei_(indi, nui, u, y0, y0u, itu, dtu, t0, tf, dti, dtf,
	 ermx, iu, nuc, nuv, ilin, nti, ntf, ny, nea, itmx, nex, nob, ntob, 
	ntobi, nitu, ndtu)
integer *indi, *nui;
doublereal *u, *y0, *y0u;
integer *itu;
doublereal *dtu, *t0, *tf, *dti, *dtf, *ermx;
integer *iu, *nuc, *nuv, *ilin, *nti, *ntf, *ny, *nea, *itmx, *nex, *nob, *
	ntob, *ntobi, *nitu, *ndtu;
{
     
    integer y0u_dim1, y0u_offset, i__1;

     
    extern   int dset_();
    static integer i__;


 
 
 

     
    --u;
    --iu;
    y0u_dim1 = *ny;
    y0u_offset = y0u_dim1 + 1;
    y0u -= y0u_offset;
    --y0;
    --itu;
    --dtu;

     
    if (*indi == 1) {
	i__1 = *ny;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    y0[i__] = u[i__];
 
	}
    }

    if (*indi == 2) {
 
	i__1 = *ny * *nui;
	dset_(&i__1, &c_b61, &y0u[y0u_offset], &c__1);
	i__1 = *ny;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    y0u[i__ + i__ * y0u_dim1] = 1.;
 
	}
    }
}  

  int majour_(hm, hd, dd, n, hno, ir, indic, eps)
doublereal *hm, *hd, *dd;
integer *n;
doublereal *hno;
integer *ir, *indic;
doublereal *eps;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    static doublereal honm, b;
    static integer i__, j;
    static doublereal r__, y;
    static integer iplus;
    static doublereal gm;
    static integer ll, mm, np;
    static doublereal del, hml, hon;

     
    --hm;
    --dd;
    --hd;

     
    if (*n == 1) {
	goto L100;
    }

    np = *n + 1;
    if (*hno > 0.) {
	goto L99;
    }

    if (*hno == 0.) {
	goto L999;
    }
    if (*ir == 0) {
	goto L999;
    }
    hon = 1. / *hno;
    ll = 1;
    if (*indic == 0) {
	goto L1;
    }

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (hm[ll] == 0.) {
	    goto L2;
	}
 
	d__1 = dd[i__];
	hon += d__1 * d__1 / hm[ll];
L2:
	ll = ll + np - i__;
    }
    goto L3;

L1:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	dd[i__] = hd[i__];
 
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	iplus = i__ + 1;
	del = dd[i__];
	if (hm[ll] > 0.) {
	    goto L6;
	}
	dd[i__] = 0.;
	ll = ll + np - i__;
	goto L5;
L6:
 
	d__1 = del;
	hon += d__1 * d__1 / hm[ll];
	if (i__ == *n) {
	    goto L7;
	}
	i__2 = *n;
	for (j = iplus; j <= i__2; ++j) {
	    ++ll;
 
	    dd[j] -= del * hm[ll];
	}
L7:
	++ll;
L5:
	;
    }

L3:
    if (*ir <= 0) {
	goto L9;
    }
    if (hon > 0.) {
	goto L10;
    }
    if (*indic - 1 <= 0) {
	goto L99;
    } else {
	goto L11;
    }
L9:
    hon = 0.;
    *ir = -(*ir) - 1;
    goto L11;
L10:
    hon = *eps / *hno;
    if (*eps == 0.) {
	--(*ir);
    }
L11:
    mm = 1;
    honm = hon;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	j = np - i__;
	ll -= i__;
	if (hm[ll] != 0.) {
 
	    d__1 = dd[j];
	    honm = hon - d__1 * d__1 / hm[ll];
	}
	dd[j] = hon;
 
	hon = honm;
    }
    goto L13;

L99:
    mm = 0;
    honm = 1. / *hno;
L13:
    ll = 1;

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	iplus = i__ + 1;
	del = hd[i__];
	if (hm[ll] > 0.) {
	    goto L14;
	}
	if (*ir > 0) {
	    goto L15;
	}
	if (*hno < 0.) {
	    goto L15;
	}
	if (del == 0.) {
	    goto L15;
	}
	*ir = 1 - *ir;
 
	d__1 = del;
	hm[ll] = d__1 * d__1 / honm;
	if (i__ == *n) {
	    goto L999;
	}
	i__2 = *n;
	for (j = iplus; j <= i__2; ++j) {
	    ++ll;
 
	    hm[ll] = hd[j] / del;
	}
	goto L999;
L15:
	hon = honm;
	ll = ll + np - i__;
	goto L98;
L14:
	hml = del / hm[ll];
	if (mm <= 0) {
	    goto L17;
	} else {
	    goto L18;
	}
L17:
	hon = honm + del * hml;
	goto L19;
L18:
	hon = dd[i__];
L19:
	r__ = hon / honm;
	hm[ll] *= r__;
	if (r__ == 0.) {
	    goto L20;
	}
	if (i__ == *n) {
	    goto L20;
	}
	b = hml / hon;
	if (r__ > 4.) {
	    goto L21;
	}
	i__2 = *n;
	for (j = iplus; j <= i__2; ++j) {
	    ++ll;
	    hd[j] -= del * hm[ll];
 
	    hm[ll] += b * hd[j];
	}
	goto L23;
L21:
	gm = honm / hon;
	i__2 = *n;
	for (j = iplus; j <= i__2; ++j) {
	    ++ll;
	    y = hm[ll];
	    hm[ll] = b * hd[j] + y * gm;
 
	    hd[j] -= del * y;
	}
L23:
	honm = hon;
	++ll;
L98:
	;
    }

L20:
    if (*ir < 0) {
	*ir = -(*ir);
    }
    goto L999;
L100:
 
    d__1 = hd[1];
    hm[1] += *hno * (d__1 * d__1);
    *ir = 1;
    if (hm[1] > 0.) {
	goto L999;
    }
    hm[1] = 0.;
    *ir = 0;
L999:
    return 0;
}  

  int majysa_(n, nt, np, y, s, ys, lb, g, x, g1, x1, index, 
	ialg, nb)
integer *n, *nt, *np;
doublereal *y, *s, *ys;
integer *lb;
doublereal *g, *x, *g1, *x1;
integer *index, *ialg, *nb;
{
     
    integer y_dim1, y_offset, s_dim1, s_offset, i__1;

     
    static integer i__, ij;


 

 
     
    --index;
    --x1;
    --g1;
    --x;
    --g;
    --ys;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;
    --ialg;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y[*lb + i__ * y_dim1] = g[i__] - g1[i__];
	s[*lb + i__ * s_dim1] = x[i__] - x1[i__];
 
    }
    ys[*lb] = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ys[*lb] += y[*lb + i__ * y_dim1] * s[*lb + i__ * s_dim1];
 
    }

 
    if (ialg[8] == 5 && *np > 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    y[i__ * y_dim1 + 1] += y[*lb + i__ * y_dim1];
	    s[i__ * s_dim1 + 1] += s[*lb + i__ * s_dim1];
 
	}
	ys[1] = 0.;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    ys[1] += y[i__ * y_dim1 + 1] * s[i__ * s_dim1 + 1];
	}
    }


 
    if (*np < *nt) {
	++(*np);
	index[*lb] = *np;
    } else {
	ij = *lb;
	i__1 = *nt;
	for (i__ = *nb; i__ <= i__1; ++i__) {
	    ++ij;
	    if (ij > *nt) {
		ij = *nb;
	    }
	    index[i__] = ij;
 
	}
    }

 
    if (*lb == *nt) {
	*lb = *nb;
    } else {
	++(*lb);
    }

 
    return 0;
}  

  int majz_(n, np, nt, y, s, z__, ys, zs, diag, index)
integer *n, *np, *nt;
doublereal *y, *s, *z__, *ys, *zs, *diag;
integer *index;
{
     
    integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1, i__2, 
	    i__3;

     
    static integer i__, j, l, jj, jl;
    static doublereal psy, psz;


 
 

 
 


     
    --diag;
    --index;
    --zs;
    --ys;
    z_dim1 = *nt;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;

     
    l = index[1];
    i__1 = *n;
    for (jj = 1; jj <= i__1; ++jj) {
	z__[l + jj * z_dim1] = diag[jj] * s[l + jj * s_dim1];
 
    }

    zs[l] = 0.;
    i__1 = *n;
    for (jj = 1; jj <= i__1; ++jj) {
	zs[l] += z__[l + jj * z_dim1] * s[l + jj * s_dim1];
 
    }


    if (*np == 1) {
	return 0;
    }

    i__1 = *np;
    for (i__ = 2; i__ <= i__1; ++i__) {
	l = index[i__];
	i__2 = *n;
	for (jj = 1; jj <= i__2; ++jj) {
	    z__[l + jj * z_dim1] = diag[jj] * s[l + jj * s_dim1];
 
	}
	i__2 = i__ - 1;
	for (j = 1; j <= i__2; ++j) {
	    psy = 0.;
	    psz = 0.;
	    jl = index[j];
	    i__3 = *n;
	    for (jj = 1; jj <= i__3; ++jj) {
		psy += y[jl + jj * y_dim1] * s[l + jj * s_dim1];
		psz += z__[jl + jj * z_dim1] * s[l + jj * s_dim1];
 
	    }
	    i__3 = *n;
	    for (jj = 1; jj <= i__3; ++jj) {
		z__[l + jj * z_dim1] = z__[l + jj * z_dim1] + psy * y[jl + jj 
			* y_dim1] / ys[jl] - psz * z__[jl + jj * z_dim1] / zs[
			jl];
 
	    }
 
	}

	zs[l] = 0.;
	i__2 = *n;
	for (jj = 1; jj <= i__2; ++jj) {
	    zs[l] += z__[l + jj * z_dim1] * s[l + jj * s_dim1];
 
	}
 
    }

    return 0;
}  

  int n1fc1_(simul, prosca, n, xn, fn, g, dxmin, df1, epsf, 
	zero, imp, io, mode, iter, nsim, memax, iz, rz, dz, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *xn, *fn, *g, *dxmin, *df1, *epsf, *zero;
integer *imp, *io, *mode, *iter, *nsim, *memax, *iz;
doublereal *rz, *dz;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1001[] = "(\002 n1fc1   appel incoherent\002)";
    static char fmt_1000[] = "(\002 entree dans n1fc1. n=\002,i4,\002  memax=\002,i3/\002  dimensions minimales\002,2x,\002iz(\002,i4,\002)    rz(\002,i6,\002)    dz(\002,i6,\002)\002/)";

     
    integer i__1;

     
    integer s_wsfe(), e_wsfe(), do_fio();

     
    static integer nanc, nxga, naps, ntot, i__;
    extern   int n1fc1a_();
    static integer na, ne, nq, nr, ns, nx, ny, npoids, nw1, nw2, ngd, nic, 
	    nal, ngg, njc, nsa, ndz, nrr, niz, nrz;

     
    static cilist io___2400 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2424 = { 0, 0, 0, fmt_1000, 0 };
     
    --g;
    --xn;
    --iz;
    --rz;
    --dz;
    --izs;
    --rzs;
    --dzs;

     
    if (*n > 0 && *df1 > 0. && *epsf >= 0. && *zero >= 0. && *iter >= 0 && *
	    nsim >= 0 && *memax >= 1 && *dxmin > 0.) {
	goto L10;
    }
    *mode = 2;
    io___2400.ciunit = *io;
    s_wsfe(&io___2400);
    e_wsfe();
    goto L999;
L10:
    ns = 1;
    ngd = ns + *n;
    nx = ngd + *n;
    nsa = nx + *n;
    ngg = nsa + *n;
    nal = ngg + *n;
    naps = nal + *memax;
    nanc = naps + *memax;
    npoids = nanc + *memax;
    nq = npoids + *memax;
    njc = 1;
    nic = njc + *memax + 1;
    nr = 1;
    na = nr + (*memax + 1) * (*memax + 1);
    ne = na + *memax + 1;
    nrr = ne + *memax + 1;
    nxga = nrr + *memax + 1;
    ny = nxga + *memax + 1;
    nw1 = ny + *memax + 1;
    nw2 = nw1 + *memax + 1;

    niz = *memax + 1 << 1;
    nrz = nq + *n * *memax - 1;
    ndz = nw2 + *memax;
    if (*imp > 0) {
	io___2424.ciunit = *io;
	s_wsfe(&io___2424);
	do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*memax), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&niz, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nrz, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&ndz, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    i__1 = niz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	iz[i__] = 0;
    }
    i__1 = nrz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	rz[i__] = 0.;
    }
    i__1 = ndz;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dz[i__] = 0.;
    }
    n1fc1a_(simul, prosca, n, mode, &xn[1], fn, &g[1], df1, epsf, dxmin, imp, 
	    zero, io, &ntot, iter, nsim, memax, &rz[ns], &rz[ngd], &rz[nx], &
	    rz[nsa], &rz[ngg], &rz[nal], &rz[naps], &rz[nanc], &rz[npoids], &
	    rz[nq], &iz[njc], &iz[nic], &dz[nr], &dz[na], &dz[ne], &dz[nrr], &
	    dz[nxga], &dz[ny], &dz[nw1], &dz[nw2], &izs[1], &rzs[1], &dzs[1]);
    iz[1] = ntot;
L999:
    return 0;
}  

  int n1fc1a_(simul, prosca, n, mode, xn, fn, g, df0, eps0, dx,
	 imp, zero, io, ntot, iter, nsim, memax, s, gd, x, sa, gg, al, aps, 
	anc, poids, q, jc, ic, r__, a, e, rr, xga, y, w1, w2, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n, *mode;
doublereal *xn, *fn, *g, *df0, *eps0, *dx;
integer *imp;
doublereal *zero;
integer *io, *ntot, *iter, *nsim, *memax;
doublereal *s, *gd, *x, *sa, *gg, *al, *aps, *anc, *poids, *q;
integer *jc, *ic;
doublereal *r__, *a, *e, *rr, *xga, *y, *w1, *w2;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1000[] = "(\002 n1fc1   iter  nsim\002,6x,\002fn\002,11x,\002eps\002,7x,\002s2\002,9x,\002u\002,5x,\002nv\002)";
    static char fmt_1002[] = "(/\002 n1fc1\002,\002    tableau des poids\002/(\002 n1fc1\002,3x,7d10.3))";
    static char fmt_1004[] = "(\002 n1fc1\002,i7,i5,d16.7,\002   convergence a\002,d10.3,\002 pres\002,\002  (\002,d9.2,\002)\002)";
    static char fmt_1005[] = "(\002 n1fc1\002,i7,i5,d16.7,\002   faisceau reduit a\002,i3,\002 gradients\002)";
    static char fmt_1006[] = "(/\002 n1fc1    fin sur nsim\002)";
    static char fmt_1007[] = "(\002 n1fc1\002,3x,i4,i5,2x,d14.7,3d10.2,i3)";
    static char fmt_1009[] = "(\002 n1fc1\002,10x,\002logic=\002,i2,4x,\002ro=\002,d10.3,4x,\002tps=\002,d10.3,4x,\002tnc=\002,d10.3)";
    static char fmt_1010[] = "(\002 n1fc1\002,12x,\002diam2=\002,d10.3,4x,\002eta2=\002,d10.3,4x,\002ap=\002,d10.3)";
    static char fmt_1011[] = "(/\002 n1fc1    la direction ne pivote plus\002)";
    static char fmt_1012[] = "(/\002 n1fc1    fin sur iter =\002,i4)";
    static char fmt_1013[] = "(/\002 n1fc1    fin anormale de fprf2\002)";
    static char fmt_1014[] = "(/\002 n1fc1    fin sur dxmin\002)";
    static char fmt_1015[] = "(/\002 n1fc1  attention on bute sur tmax, reduire l'echelle\002)";
    static char fmt_1016[] = "(/\002 n1fc1    fin normale\002)";
    static char fmt_1017[] = "(1x)";
    static char fmt_1018[] = "(/\002 n1fc1    fin sur indic=0\002)";

     
    integer i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    integer s_wsfe(), e_wsfe(), do_fio();
    double sqrt();

     
    static doublereal alfa, beta, epsm, tmin, tmax, diam2;
    extern   int frdf1_(), fprf2_(), nlis2_();
    static doublereal f;
    static integer i__, k, j, iflag;
    static doublereal u;
    static integer indic, kgrad;
    static doublereal z__;
    static integer logic, itmax, itimp;
    static doublereal ajust, s2, s3;
    extern   int ffinf1_();
    static doublereal z1, z2;
    static integer logic2;
    extern   int fremf1_();
    static integer memax1;
    static doublereal fa, df, ap;
    static integer nk, mm;
    static doublereal ro;
    static integer nv, napmax, nt1;
    static doublereal s3n, roa;
    static integer nta;
    static doublereal eps, fpn, tnc;
    static integer nki;
    static doublereal tol, tps, eta2;

     
    static cilist io___2444 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2445 = { 0, 0, 0, fmt_1012, 0 };
    static cilist io___2452 = { 0, 0, 0, fmt_1013, 0 };
    static cilist io___2456 = { 0, 0, 0, fmt_1004, 0 };
    static cilist io___2457 = { 0, 0, 0, fmt_1016, 0 };
    static cilist io___2459 = { 0, 0, 0, fmt_1017, 0 };
    static cilist io___2460 = { 0, 0, 0, fmt_1007, 0 };
    static cilist io___2461 = { 0, 0, 0, fmt_1002, 0 };
    static cilist io___2463 = { 0, 0, 0, fmt_1011, 0 };
    static cilist io___2473 = { 0, 0, 0, fmt_1014, 0 };
    static cilist io___2474 = { 0, 0, 0, fmt_1006, 0 };
    static cilist io___2475 = { 0, 0, 0, fmt_1018, 0 };
    static cilist io___2476 = { 0, 0, 0, fmt_1015, 0 };
    static cilist io___2478 = { 0, 0, 0, fmt_1010, 0 };
    static cilist io___2480 = { 0, 0, 0, fmt_1005, 0 };
    static cilist io___2481 = { 0, 0, 0, fmt_1009, 0 };


 

 

     
    --gg;
    --sa;
    --x;
    --gd;
    --s;
    --g;
    --xn;
    --poids;
    --anc;
    --aps;
    --al;
    --q;
    --jc;
    --ic;
    --r__;
    --a;
    --e;
    --rr;
    --xga;
    --y;
    --w1;
    --w2;
    --izs;
    --rzs;
    --dzs;

     
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
    itmax = *iter;
    *iter = 0;
    itimp = 0;
    napmax = *nsim;
    *nsim = 1;
    logic = 1;
    logic2 = 0;
    tmax = 1e20;
    eps = *df0;
    epsm = eps;
    df = *df0;
    *mode = 1;
    *ntot = 0;
    iflag = 0;

 
 

    aps[1] = 0.;
    anc[1] = 0.;
    poids[1] = 0.;
    nta = 0;
    kgrad = 1;
    memax1 = *memax + 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	q[i__] = -g[i__];
    }
    (*prosca)(n, &g[1], &g[1], &diam2, &izs[1], &rzs[1], &dzs[1]);
    diam2 = *df0 * 100. * *df0 / diam2;
    eta2 = *eps0 * .01 * *eps0 / diam2;
    ap = *zero * *df0 / diam2;
    if (*imp > 2) {
	io___2444.ciunit = *io;
	s_wsfe(&io___2444);
	e_wsfe();
    }

 

L100:
    ++(*iter);
    ++itimp;
    if (*iter < itmax) {
	goto L110;
    }
    if (*imp > 0) {
	io___2445.ciunit = *io;
	s_wsfe(&io___2445);
	do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    *mode = 4;
    goto L900;
L110:
    ++(*ntot);
    if (logic == 3) {
	ro *= sqrt(s2);
    }
    if (itimp != -(*imp)) {
	goto L200;
    }
    itimp = 0;
    indic = 1;
    (*simul)(&indic, n, &xn[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]);

 

L200:
    eps = (( eps ) <= ( epsm ) ? ( eps ) : ( epsm )) ;
    eps = (( eps ) >= ( *eps0 ) ? ( eps ) : ( *eps0 )) ;
    fremf1_(prosca, &iflag, n, ntot, &nta, &memax1, &q[1], &poids[1], &e[1], &
	    a[1], &r__[1], &izs[1], &rzs[1], &dzs[1]);
    fprf2_(&iflag, ntot, &nv, io, zero, &s2, &eps, &al[1], imp, &u, &eta2, &
	    memax1, &jc[1], &ic[1], &r__[1], &a[1], &e[1], &rr[1], &xga[1], &
	    y[1], &w1[1], &w2[1]);

 

    if (iflag == 0) {
	goto L250;
    }
    if (*imp > 0) {
	io___2452.ciunit = *io;
	s_wsfe(&io___2452);
	e_wsfe();
    }
    *mode = 7;
    goto L900;
L250:
    nta = *ntot;
    ffinf1_(n, &nv, &jc[1], &xga[1], &q[1], &s[1]);
    u = (( u ) >= ( 0. ) ? ( u ) : ( 0. )) ;
    s2 = (( s2 ) >= ( 0. ) ? ( s2 ) : ( 0. )) ;

 

    if (s2 > eta2) {
	goto L300;
    }

 
    z__ = 0.;
    i__1 = nv;
    for (k = 1; k <= i__1; ++k) {
	j = jc[k] - 1;
	if (j > 0) {
	    z__ += xga[k] * poids[j];
	}
 
    }
    epsm = (( epsm ) <= ( z__ ) ? ( epsm ) : ( z__ )) ;
    if (*imp >= 2) {
	io___2456.ciunit = *io;
	s_wsfe(&io___2456);
	do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&epsm, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&s2, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (epsm > *eps0) {
	goto L270;
    }
    *mode = 1;
    if (*imp > 0) {
	io___2457.ciunit = *io;
	s_wsfe(&io___2457);
	e_wsfe();
    }
    goto L900;

 
L270:
 
    d__1 = epsm * .1;
    epsm = (( d__1 ) >= ( *eps0 ) ? ( d__1 ) : ( *eps0 )) ;
    eps = epsm;
    if (logic == 3) {
	tol = eps * .01;
    }
    iflag = 2;
    goto L200;

 
 

L300:
    if (*imp > 3) {
	io___2459.ciunit = *io;
	s_wsfe(&io___2459);
	e_wsfe();
    }
    if (*imp > 2) {
	io___2460.ciunit = *io;
	s_wsfe(&io___2460);
	do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&s2, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&u, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&nv, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*imp >= 6) {
	io___2461.ciunit = *io;
	s_wsfe(&io___2461);
	i__1 = *ntot;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_fio(&c__1, (char *)&poids[i__], (ftnlen)sizeof(doublereal));
	}
	e_wsfe();
    }
 
    if (logic != 3) {
	goto L350;
    }
    z__ = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z1 = s[i__] - sa[i__];
 
	z__ += z1 * z1;
    }
    if (z__ > *zero * 10. * *zero * s2) {
	goto L350;
    }
    if (*imp > 0) {
	io___2463.ciunit = *io;
	s_wsfe(&io___2463);
	e_wsfe();
    }
    *mode = 8;
    goto L900;

 

L350:
    iflag = 3;
    s3 = s2 + u * eps;
    if (logic == 3) {
	goto L365;
    }
    ro = df * 2. / s3;
    tol = eps * .01;
    goto L370;
L365:
    ro /= sqrt(s2);
 
    d__1 = tol * .6, d__2 = *eps0 * .01;
    tol = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
L370:
    fa = *fn;
    alfa = .2;
    beta = .1;
    fpn = -s3;
    if (*memax == 1) {
	tol = 0.;
    }
 
    tmin = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__2 = tmin, d__3 = (d__1 = s[i__] / *dx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	tmin = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    }
    tmin = 1. / tmin;
    if (*iter == 1) {
	roa = ro;
    }
    nlis2_(simul, prosca, n, &xn[1], fn, &fpn, &ro, &tmin, &tmax, &s[1], &s2, 
	    &g[1], &gd[1], &alfa, &beta, imp, io, &logic, nsim, &napmax, &x[1]
	    , &tol, &ap, &tps, &tnc, &gg[1], &izs[1], &rzs[1], &dzs[1]);
    if (logic == 0 || logic == 2 || logic == 3) {
	goto L380;
    }
 
    if (*imp <= 0) {
	goto L375;
    }
    if (logic == 6 || logic < 0) {
	io___2473.ciunit = *io;
	s_wsfe(&io___2473);
	e_wsfe();
    }
    if (logic == 4) {
	io___2474.ciunit = *io;
	s_wsfe(&io___2474);
	e_wsfe();
    }
    if (logic == 5) {
	io___2475.ciunit = *io;
	s_wsfe(&io___2475);
	e_wsfe();
    }
    if (logic == 1) {
	io___2476.ciunit = *io;
	s_wsfe(&io___2476);
	e_wsfe();
    }
L375:
    if (logic == 1) {
	*mode = 3;
    }
    if (logic == 4) {
	*mode = 5;
    }
    if (logic == 5) {
	*mode = 0;
    }
    if (logic == 6) {
	*mode = 6;
    }
    if (logic < 0) {
	*mode = logic;
    }
    goto L900;
L380:
    if (logic != 3) {
	goto L385;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	sa[i__] = s[i__];
    }
L385:
    if (*iter > 1) {
	goto L390;
    }

 
    if (logic == 0) {
	tps = *fn - fa - ro * fpn;
    }
    ap = *zero * *zero * (( tps ) >= 0 ? ( tps ) : -( tps ))  / (s2 * ro * ro);
    ajust = ro / roa;
    if (logic != 3) {
	diam2 = diam2 * ajust * ajust;
    }
    if (logic != 3) {
	eta2 /= ajust * ajust;
    }
    if (*imp >= 2) {
	io___2478.ciunit = *io;
	s_wsfe(&io___2478);
	do_fio(&c__1, (char *)&diam2, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&eta2, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ap, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
L390:
    mm = *memax - 1;
    if (logic == 2) {
	mm = *memax - 2;
    }
    if (*ntot <= mm) {
	goto L400;
    }

 

    frdf1_(prosca, n, ntot, &mm, &kgrad, &al[1], &q[1], &s[1], &poids[1], &
	    aps[1], &anc[1], &memax1, &r__[1], &e[1], &ic[1], &izs[1], &rzs[1]
	    , &dzs[1]);
    iflag = 1;
    nta = *ntot;
    if (*imp >= 2) {
	io___2480.ciunit = *io;
	s_wsfe(&io___2480);
	do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*fn), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*ntot), (ftnlen)sizeof(integer));
	e_wsfe();
    }

L400:
    if (*imp >= 5) {
	io___2481.ciunit = *io;
	s_wsfe(&io___2481);
	do_fio(&c__1, (char *)&logic, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&ro, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&tps, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&tnc, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (logic == 3) {
	goto L500;
    }

 

    iflag = (( iflag ) <= ( 2 ) ? ( iflag ) : ( 2 )) ;
    df = fa - *fn;
    if (*ntot == 0) {
	goto L500;
    }

 

    s3n = ro * sqrt(s2);
    i__1 = *ntot;
    for (k = 1; k <= i__1; ++k) {
	nk = (k - 1) * *n;
	z__ = 0.;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    nki = nk + i__;
 

 
	    z__ += q[nki] * s[i__];
	}
	y[k] = z__;
	z1 = (d__1 = aps[k] + (-df + ro * z__), (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	z2 = anc[k] + s3n;
 
	d__1 = z1, d__2 = ap * z2 * z2;
	poids[k] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	aps[k] = z1;
	anc[k] = z2;
 
    }

 

    eps = ro * s3;
    kgrad = *ntot + 1;

 

L500:
    nt1 = *ntot + 1;
    if (logic == 3) {
	goto L510;
    }
    aps[nt1] = 0.;
    anc[nt1] = 0.;
    poids[nt1] = 0.;
    goto L520;
L510:
    aps[nt1] = tps;
    anc[nt1] = sqrt(tnc);
 
    d__1 = tps, d__2 = ap * tnc;
    poids[nt1] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
L520:
    nk = *ntot * *n;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	nki = nk + i__;
 
	q[nki] = -g[i__];
    }

 
    if (logic != 2) {
	goto L550;
    }
    ++(*ntot);
    logic = 3;
    logic2 = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	g[i__] = gd[i__];
    }
    goto L390;
L550:
    logic -= logic2;
    logic2 = 0;
    goto L100;

 

L900:
    if (*iter <= 1) {
	goto L990;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	g[i__] = -s[i__];
    }
L990:
    return 0;
}  

  int n1gc2_(simul, prosca, n, x, f, g, dxmin, df1, epsrel, 
	imp, io, mode, niter, nsim, rz, nrz, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *x, *f, *g, *dxmin, *df1, *epsrel;
integer *imp, *io, *mode, *niter, *nsim;
doublereal *rz;
integer *nrz, *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1[] = "(\002 entree dans n1gc2:\002,6x,\002dimension du probleme \002,i3/2x,\002nrz=\002,i4,4x,\002niter=\002,i3,4x,\002nsim=\002,i4,4x,\002imp=\002,i3/2x,\002epsrel=\002,d8.2,4x,\002df1=\002,d8.2,4x,\002dxmin=\002,d8.2)";
    static char fmt_3[] = "(/,\002 n1gc2   appel incoherent\002)";
    static char fmt_2[] = "(/,\002 n1gc2   rz insuffisamment dimensionne\002)"
	    ;
    static char fmt_4[] = "(/,\002 n1gc2   fin sur dxmin\002)";
    static char fmt_5[] = "(/,\002 sortie de n1gc2\002,7x,\002norme de g =\002,d15.9/9x,\002niter=\002,i4,4x,\002nsim=\002,i5)";

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static integer memh, iaux;
    extern   int n1gc2a_();
    static integer id, ig, ih, ix;

     
    static cilist io___2487 = { 0, 0, 0, fmt_1, 0 };
    static cilist io___2488 = { 0, 0, 0, fmt_3, 0 };
    static cilist io___2495 = { 0, 0, 0, fmt_2, 0 };
    static cilist io___2496 = { 0, 0, 0, fmt_4, 0 };
    static cilist io___2497 = { 0, 0, 0, fmt_5, 0 };


 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --g;
    --x;
    --rz;
    --izs;
    --rzs;
    --dzs;

     
    if (*imp > 0) {
	io___2487.ciunit = *io;
	s_wsfe(&io___2487);
	do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nrz), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*imp), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*df1), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*dxmin), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*n <= 0 || *niter <= 0 || *nsim <= 0 || *dxmin <= 0. || *df1 <= 0. || 
	    *epsrel <= 0. || *epsrel > 1.) {
	*mode = 2;
	if (*imp > 0) {
	    io___2488.ciunit = *io;
	    s_wsfe(&io___2488);
	    e_wsfe();
	}
	return 0;
    }

 
    id = 1;
    ix = id + *n;
    ig = ix + *n;
    iaux = ig + *n;
    ih = iaux + *n;

 
    memh = *nrz - (*n << 2);

    if (memh <= 0) {
	*mode = 3;
	goto L100;
    } else {
    }

 
    n1gc2a_(simul, prosca, n, &x[1], f, &g[1], dxmin, df1, epsrel, imp, io, 
	    niter, nsim, mode, &memh, &rz[id], &rz[ix], &rz[ig], &rz[iaux], &
	    rz[ih], &izs[1], &rzs[1], &dzs[1]);

L100:
    if (*imp > 0) {
	if (*mode == 3) {
	    io___2495.ciunit = *io;
	    s_wsfe(&io___2495);
	    e_wsfe();
	} else if (*mode == 6) {
	    io___2496.ciunit = *io;
	    s_wsfe(&io___2496);
	    e_wsfe();
	} else {
	    io___2497.ciunit = *io;
	    s_wsfe(&io___2497);
	    do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal));
	    do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    }
    return 0;
}  

  int n1gc2a_(simul, prosca, n, x, f, g, dx, df1, eps, imp, io,
	 niter, nsim, info, memh, d__, xx, gg, tabaux, h__, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *x, *f, *g, *dx, *df1, *eps;
integer *imp, *io, *niter, *nsim, *info, *memh;
doublereal *d__, *xx, *gg, *tabaux, *h__;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1[] = "(\002     methode de quasi-newton. nrz utile=\002,i7)";
    static char fmt_2[] = "(\002     methode du gradient conjugue avec\002,i3,\002 mises a jour.\002,\002 nrz utile=\002,i7)";
    static char fmt_6003[] = "()";
    static char fmt_6002[] = "(4x,\002 n1gc2\002,3x,i4,\002 iters\002,3x,i4,\002 simuls\002,\002 necessite d'un redemarrage total\002)";
    static char fmt_6001[] = "(4x,\002 n1gc2\002,3x,i4,\002 iters\002,3x,i4,\002 simuls\002,3x,\002f=\002,d15.9)";
    static char fmt_10101[] = "(\002 n1gc2a   erreur dans la hessienne   dg=\002,d9.2)";

     
    integer i__1, i__2;
    doublereal d__1;

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static integer ieta, iter, i__, j, k, m;
    extern   int n1gc2b_();
    static integer l;
    static doublereal alpha, omega;
    static logical redem;
    static doublereal sigma;
    static logical termi;
    static doublereal normg;
    extern   int fmulb1_();
    static doublereal normg0;
    extern   int fmuls1_();
    static logical gc;
    static doublereal dg;
    static integer kj, lk, is, iu;
    static doublereal mu, gcarre, ggcarr, nu, sscaek, sscalg, uscalg;
    static integer nmisaj;
    static logical redfor;
    static doublereal dg1;
    static integer memuti;
    static logical intfor, iterqn;
    static integer ntotap, memsup, km1, kp1, retour, nrzuti;
    static doublereal eta;
    static integer inu;
    static doublereal aux1, aux2;

     
    static cilist io___2502 = { 0, 0, 0, fmt_1, 0 };
    static cilist io___2504 = { 0, 0, 0, fmt_2, 0 };
    static cilist io___2518 = { 0, 0, 0, fmt_6003, 0 };
    static cilist io___2519 = { 0, 0, 0, fmt_6002, 0 };
    static cilist io___2523 = { 0, 0, 0, fmt_6001, 0 };
    static cilist io___2546 = { 0, 0, 0, fmt_10101, 0 };



 
 
 


 
 
 

     
    --tabaux;
    --gg;
    --xx;
    --d__;
    --g;
    --x;
    --h__;
    --izs;
    --rzs;
    --dzs;

     
    memuti = *n * (*n + 1) / 2;

 
    memsup = (*n << 1) + 2;

    if (*memh >= memuti) {
	gc = (0) ;
	nrzuti = memuti + (*n << 2);
	if (*imp > 1) {
	    io___2502.ciunit = *io;
	    s_wsfe(&io___2502);
	    do_fio(&c__1, (char *)&nrzuti, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    } else if (*memh < memsup) {
	*info = 3;
	return 0;
    } else {
	gc = (1) ;
 
	m = *memh / memsup;
 

	memuti = m * memsup;
	nrzuti = memuti + (*n << 2);
	if (*imp > 1) {
	    io___2504.ciunit = *io;
	    s_wsfe(&io___2504);
	    do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&nrzuti, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
    }

 
 
 

 
    iter = 0;
    ntotap = 1;

 
 
 

L3000:
    i__ = 0;
    nmisaj = 0;

 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	d__[j] = -g[j];
 
    }

    (*prosca)(n, &g[1], &d__[1], &dg1, &izs[1], &rzs[1], &dzs[1]);
    normg0 = sqrt(((( dg1 ) >= 0 ? ( dg1 ) : -( dg1 )) ));
    if (iter == 1) {
	omega = *eps * normg0;
    }

 
 
 

L4000:
    if (iter == *niter) {
	*info = 4;
	goto L99999;
    }
    ++iter;
    ++i__;

 
    if (gc) {
	iterqn = i__ <= m && 2 <= i__;
    }

 
 
 

    if (iter == 2) {
	alpha = *df1 * 2. / (-dg1);
    } else if (gc) {
	if (i__ == 1) {
	    alpha = 1. / normg0;
	} else {
	    if (iterqn) {
		alpha = 1.;
	    } else {
		alpha = alpha * dg / dg1;
	    }
	}
    } else {
	alpha = 1.;
    }

 
 
 

    dg = dg1;
    intfor = gc && ! iterqn || ! gc && i__ == 1;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	xx[j] = x[j];
	gg[j] = g[j];
 
    }
    n1gc2b_(n, simul, prosca, &xx[1], f, &dg, &alpha, &d__[1], &x[1], &g[1], 
	    imp, io, &retour, &ntotap, nsim, &intfor, dx, eps, &izs[1], &rzs[
	    1], &dzs[1]);

    if (*imp > 3) {
	io___2518.ciunit = *io;
	s_wsfe(&io___2518);
	e_wsfe();
    }
    if (retour == 4 || retour == 1 && i__ == 1) {
	*info = 6;
	return 0;
    } else if (retour == 1) {
	if (*imp > 1) {
	    io___2519.ciunit = *io;
	    s_wsfe(&io___2519);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&ntotap, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	goto L3000;
    } else {
 
	if (i__ > 1 && gc) {
	    ggcarr = gcarre;
	}
	(*prosca)(n, &g[1], &g[1], &gcarre, &izs[1], &rzs[1], &dzs[1]);
	normg = sqrt(gcarre);
	if (*imp > 2) {
	    io___2523.ciunit = *io;
	    s_wsfe(&io___2523);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&ntotap, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	if (retour == 2) {
	    *info = 0;
	    goto L99999;
	} else if (retour == 3) {
	    *info = 5;
	    goto L99999;
	}
    }

 
 
 

    termi = normg < omega;
    if (termi) {
	*info = 1;
	goto L99999;
    } else {
    }

 
 
 

 
    redfor = gc && (i__ == 1 || i__ == m + *n);
    if (redfor) {
	redem = (1) ;
    } else if (gc && ! iterqn) {
	(*prosca)(n, &g[1], &gg[1], &aux1, &izs[1], &rzs[1], &dzs[1]);
	redem = (( aux1 ) >= 0 ? ( aux1 ) : -( aux1 ))  > (d__1 = ggcarr * .2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    } else {
	redem = (0) ;
    }

 
 
 

 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	d__[j] = alpha * d__[j];
	xx[j] = g[j] - gg[j];
 
    }
    if (redem) {
 
	i__ = 1;
	nmisaj = 1;
 
 
 
 
 
	inu = 1;
	ieta = inu + 1;
	iu = ieta;
	is = iu + *n;

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    h__[iu + j] = xx[j];
	    h__[is + j] = d__[j];
 
	}
	(*prosca)(n, &xx[1], &xx[1], &nu, &izs[1], &rzs[1], &dzs[1]);
	h__[inu] = nu;
	(*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]);
	h__[ieta] = eta;
 
 
	fmulb1_(n, &h__[1], &g[1], &xx[1], &tabaux[1], &nmisaj, prosca, &izs[
		1], &rzs[1], &dzs[1]);

    } else if (gc) {
 
 
	fmulb1_(n, &h__[1], &xx[1], &gg[1], &tabaux[1], &nmisaj, prosca, &izs[
		1], &rzs[1], &dzs[1]);
 
	(*prosca)(n, &xx[1], &gg[1], &nu, &izs[1], &rzs[1], &dzs[1]);
	(*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]);
	(*prosca)(n, &d__[1], &g[1], &sscalg, &izs[1], &rzs[1], &dzs[1]);
	(*prosca)(n, &gg[1], &g[1], &uscalg, &izs[1], &rzs[1], &dzs[1]);
 
	sigma = (uscalg - (nu / eta + 1.) * sscalg) / eta;
	mu = sscalg / eta;
 
	fmulb1_(n, &h__[1], &g[1], &xx[1], &tabaux[1], &nmisaj, prosca, &izs[
		1], &rzs[1], &dzs[1]);
 
 
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    xx[j] = xx[j] - mu * gg[j] - sigma * d__[j];
 
	}

 
	if (iterqn) {
	    ++nmisaj;
 

	    inu += memsup;
	    ieta = inu + 1;
	    iu = ieta;
	    is = iu + *n;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		h__[iu + j] = gg[j];
		h__[is + j] = d__[j];
 
	    }
	    h__[inu] = nu;
	    h__[ieta] = eta;
	}
 
    } else {
 
	(*prosca)(n, &d__[1], &xx[1], &eta, &izs[1], &rzs[1], &dzs[1]);
	if (i__ == 1) {
 

 
 
	    (*prosca)(n, &xx[1], &xx[1], &nu, &izs[1], &rzs[1], &dzs[1]);
 
	    kj = 1;
	    aux1 = eta / nu;
	    i__1 = *n;
	    for (k = 1; k <= i__1; ++k) {
		h__[kj] = aux1;
		++kj;
		kp1 = k + 1;
		if (*n >= kp1) {
		    i__2 = *n;
		    for (j = kp1; j <= i__2; ++j) {
			h__[kj] = 0.;
			++kj;
 
		    }
		}
		gg[k] = aux1 * xx[k];
 
	    }
	    nu = eta;
	} else {
	    fmuls1_(n, &h__[1], &xx[1], &gg[1]);
	    (*prosca)(n, &xx[1], &gg[1], &nu, &izs[1], &rzs[1], &dzs[1]);
	}
 

 
	aux1 = nu / eta + 1.;
	kj = 1;
	i__1 = *n;
	for (k = 1; k <= i__1; ++k) {
 
	    lk = k;
	    km1 = k - 1;
	    if (k >= 2) {
		i__2 = km1;
		for (l = 1; l <= i__2; ++l) {
		    tabaux[l] = h__[lk];
		    lk += *n - l;
 
		}
	    }
	    i__2 = *n;
	    for (l = k; l <= i__2; ++l) {
		tabaux[l] = h__[lk];
		++lk;
 
	    }

	    (*prosca)(n, &xx[1], &tabaux[1], &aux2, &izs[1], &rzs[1], &dzs[1])
		    ;
	    i__2 = *n;
	    for (l = 1; l <= i__2; ++l) {
		tabaux[l] = 0.;
 
	    }
	    tabaux[k] = 1.;
	    (*prosca)(n, &tabaux[1], &d__[1], &sscaek, &izs[1], &rzs[1], &dzs[
		    1]);
	    kj = k - *n;
	    i__2 = k;
	    for (j = 1; j <= i__2; ++j) {
		kj = kj + *n - j + 1;
		h__[kj] -= ((aux2 - aux1 * sscaek) * d__[j] + sscaek * gg[j]) 
			/ eta;
 
	    }
 
	}
    }

 
 
 

    if (gc) {
 
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    d__[j] = -xx[j];
 
	}

    } else {
 
 
	fmuls1_(n, &h__[1], &g[1], &d__[1]);
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    d__[j] = -d__[j];
 
	}
    }

 
    (*prosca)(n, &d__[1], &g[1], &dg1, &izs[1], &rzs[1], &dzs[1]);
    if (dg1 >= 0.) {
	*info = 7;
	if (*imp > 1) {
	    io___2546.ciunit = *io;
	    s_wsfe(&io___2546);
	    do_fio(&c__1, (char *)&dg1, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	goto L99999;
    } else {
	goto L4000;
    }

 
L99999:
    *niter = iter;
    *nsim = ntotap;
    if (i__ == 0) {
	*eps = normg0;
    } else {
	*eps = normg;
    }
}  

  int n1gc2b_(n, simul, prosca, xinit, f, dg, alpha, d__, 
	xfinal, gfinal, imp, io, retour, ntotap, nsim, intfor, dx, eps, izs, 
	rzs, dzs)
integer *n;
  int (*simul) (), (*prosca) ();
doublereal *xinit, *f, *dg, *alpha, *d__, *xfinal, *gfinal;
integer *imp, *io, *retour, *ntotap, *nsim;
logical *intfor;
doublereal *dx, *eps;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1[] = "(\002 n1gc2b\002,6x,\002  pas\002,d10.3,\002  dg=\002,d9.2)";
    static char fmt_1001[] = "(\002 n1gc2b    fin sur dx\002)";
    static char fmt_2001[] = "(\002 n1gc2b\002,20x,d10.3,\002  indic=\002,i3)"
	    ;
    static char fmt_2002[] = "(\002 n1gc2b\002,20x,d10.3,2d11.3)";

     
    integer i__1;
    doublereal d__1;

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static doublereal bsup;
    static integer j, indic;
    static doublereal delta;
    static logical depas;
    static doublereal finit, ap, dp, at, fp;
    static logical encadr, accept, rfinie;
    static integer nappel;
    static logical maxpas;
    static doublereal dal, pas, aux1, aux2;

     
    static cilist io___2554 = { 0, 0, 0, fmt_1, 0 };
    static cilist io___2556 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2559 = { 0, 0, 0, fmt_2001, 0 };
    static cilist io___2563 = { 0, 0, 0, fmt_2002, 0 };



 
 
 

 
     
    --gfinal;
    --xfinal;
    --d__;
    --xinit;
    --izs;
    --rzs;
    --dzs;

     
    depas = (0) ;
    bsup = 0.;
    finit = *f;
    nappel = 0;
    ap = 0.;
    fp = finit;
    dp = *dg;
    if (*imp > 3) {
	io___2554.ciunit = *io;
	s_wsfe(&io___2554);
	do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*dg), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
    (*prosca)(n, &d__[1], &d__[1], &pas, &izs[1], &rzs[1], &dzs[1]);
    pas = sqrt(pas);
 
L1000:
    if (*alpha * pas <= *dx) {
	if (*imp > 3) {
	    io___2556.ciunit = *io;
	    s_wsfe(&io___2556);
	    e_wsfe();
	}
	*retour = 1;
	return 0;
    } else if (*ntotap == *nsim) {
	*retour = 3;
	return 0;
    } else {
    }
 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	xfinal[j] = xinit[j] + *alpha * d__[j];
 
    }
 
    indic = 4;
    (*simul)(&indic, n, &xfinal[1], f, &gfinal[1], &izs[1], &rzs[1], &dzs[1]);
    ++nappel;
    ++(*ntotap);
    if (indic < 0) {
	depas = (1) ;
	if (*imp > 3) {
	    io___2559.ciunit = *io;
	    s_wsfe(&io___2559);
	    do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
	    do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	delta = *alpha - ap;
	if (delta <= *dx) {
	    *retour = 4;
	    return 0;
	} else {
	    bsup = *alpha;
	    *alpha = delta * .1 + ap;
	    goto L1000;
	}
    }
 
    (*prosca)(n, &d__[1], &gfinal[1], &dal, &izs[1], &rzs[1], &dzs[1]);

    if (*imp > 3) {
	aux2 = *f - finit;
	io___2563.ciunit = *io;
	s_wsfe(&io___2563);
	do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&aux2, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&dal, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (indic == 0) {
	*retour = 2;
	return 0;
    }
    maxpas = *f > finit && dal < 0.;
    if (maxpas) {
	*alpha /= 3.;
	ap = 0.;
	fp = finit;
	dp = *dg;
	rfinie = (0) ;

    } else {
 
	aux1 = finit + *alpha * 1e-4 * *dg;
	aux2 = (d__1 = dal / *dg, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	accept = *f <= aux1 && aux2 <= .9;
	if (accept) {
 
	    rfinie = nappel > 1 || ! (*intfor) || aux2 <= *eps;
	} else {
	    rfinie = (0) ;
	}

	if (! rfinie) {
 
	    aux1 = dp + dal - (fp - *f) * 3. / (ap - *alpha);
	    aux2 = aux1 * aux1 - dp * dal;
	    if (aux2 <= 0.) {
		aux2 = 0.;
	    } else {
		aux2 = sqrt(aux2);
	    }
	    if (dal - dp + aux2 * 2. == 0.) {
		*retour = 4;
		return 0;
	    }
	    at = *alpha - (*alpha - ap) * (dal + aux2 - aux1) / (dal - dp + 
		    aux2 * 2.);
 
	    encadr = dal / dp <= 0.;
	    if (encadr) {
 
		if ((d__1 = *alpha - ap, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *dx) {
		    *retour = 4;
		    return 0;
		}
		aux1 = (( *alpha ) <= ( ap ) ? ( *alpha ) : ( ap ))  * 1.01;
		aux2 = (( *alpha ) >= ( ap ) ? ( *alpha ) : ( ap ))  * .99;
		if (at < aux1 || at > aux2) {
		    at = (*alpha + ap) / 2.;
		}
	    } else {
 
		aux1 = (( ap ) <= ( *alpha ) ? ( ap ) : ( *alpha ))  * .99;
		if (dal <= 0. || at <= 0. || at >= aux1) {
		    aux1 = (( ap ) >= ( *alpha ) ? ( ap ) : ( *alpha ))  * 1.01;
		    if (dal > 0. || at <= aux1) {
			if (dal <= 0.) {
			    at = (( ap ) >= ( *alpha ) ? ( ap ) : ( *alpha ))  * 2.;
			} else {
			    at = (( ap ) <= ( *alpha ) ? ( ap ) : ( *alpha ))  / 2.;
			}
		    }
		}
	    }
	    if (depas && at >= bsup) {
		delta = bsup - *alpha;
		if (delta <= *dx) {
		    *retour = 4;
		    return 0;
		} else {
		    at = *alpha + delta * .1;
		}
	    }
	    ap = *alpha;
	    fp = *f;
	    dp = dal;
	    *alpha = at;
	}
    }
    if (rfinie) {
	*retour = 0;
	return 0;
    } else {
	goto L1000;
    }
}  

  int n1qn1_(simul, n, x, f, g, var, eps, mode, niter, nsim, 
	imp, lp, zm, izs, rzs, dzs)
  int (*simul) ();
integer *n;
doublereal *x, *f, *g, *var, *eps;
integer *mode, *niter, *nsim, *imp, *lp;
doublereal *zm;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1000[] = "(\0021entree dans n1qn1. dimension du probleme\002,i4,\002,   de zm\002,i6)";
    static char fmt_1003[] = "(\002 mode\002,i2,\002   eps=\002,d10.2,\002   niter=\002,i4,\002 nsim=\002,i5,\002 imp=\002,i3)";
    static char fmt_1100[] = "(\002 sortie de n1qn1\002,\002. norme gradient carre =\002,d15.7)";

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    extern   int n1qn1a_();
    static integer nd, nw, nga, ngb, nxa, nxb;

     
    static cilist io___2571 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2572 = { 0, 0, 0, fmt_1003, 0 };
    static cilist io___2578 = { 0, 0, 0, fmt_1100, 0 };
     
    --var;
    --g;
    --x;
    --zm;
    --izs;
    --rzs;
    --dzs;

     
 
 
 
    if (*imp <= 0) {
	goto L10;
    }
    nw = *n * (*n + 13) / 2;
    io___2571.ciunit = *lp;
    s_wsfe(&io___2571);
    do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&nw, (ftnlen)sizeof(integer));
    e_wsfe();
    io___2572.ciunit = *lp;
    s_wsfe(&io___2572);
    do_fio(&c__1, (char *)&(*mode), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*imp), (ftnlen)sizeof(integer));
    e_wsfe();
L10:
    nd = *n * (*n + 1) / 2 + 1;
    nw = nd + *n;
    nxa = nw + *n;
    nga = nxa + *n;
    nxb = nga + *n;
    ngb = nxb + *n;
    n1qn1a_(simul, n, &x[1], f, &g[1], &var[1], eps, mode, niter, nsim, imp, 
	    lp, &zm[1], &zm[nd], &zm[nw], &zm[nxa], &zm[nga], &zm[nxb], &zm[
	    ngb], &izs[1], &rzs[1], &dzs[1]);
    if (*imp > 0) {
	io___2578.ciunit = *lp;
	s_wsfe(&io___2578);
	do_fio(&c__1, (char *)&(*eps), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    return 0;
}  

  int n1qn1a_(simul, n, x, f, g, scale, acc, mode, niter, nsim,
	 iprint, lp, h__, d__, w, xa, ga, xb, gb, izs, rzs, dzs)
  int (*simul) ();
integer *n;
doublereal *x, *f, *g, *scale, *acc;
integer *mode, *niter, *nsim, *iprint, *lp;
doublereal *h__, *d__, *w, *xa, *ga, *xb, *gb;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1000[] = "(\002 n1qn1 ne peut demarrer (contrainte implicite)\002)";
    static char fmt_1001[] = "(\002 n1qn1 termine par voeu de l'utilisateur\002)";
    static char fmt_1010[] = "(\002 n1qn1 remplace le hessien initial (qui n'est\002,\002 pas defini positif)\002/\002 par une diagonale positive\002)";
    static char fmt_1019[] = "(\002+\002,51x,\002deriv init =\002,d11.4)";
    static char fmt_1020[] = "(\002 n1qn1\002,i4,\002 iters\002,i6,\002 simuls\002,\002   f=\002,d15.7)";
    static char fmt_1021[] = "(\002 n1qn1\002,13x,\002pas\002,d12.5,\002  diff f =\002,d11.4,\002  deriv =\002,d11.4)";
    static char fmt_1022[] = "(\002 n1qn1\002,13x,\002pas\002,d12.5,\002  indic =\002,i2)";
    static char fmt_1023[] = "(\002 n1qn1 bute sur une contrainte implicite\002)";

     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2, d__3, d__4;

     
    integer s_wsfe(), e_wsfe(), do_fio();
    double sqrt();

     
    static doublereal fmin, gmin;
    static integer nfun, isfv;
    static doublereal step, c__;
    static integer i__, j, k;
    static doublereal s;
    static integer indic;
    static doublereal v;
    static integer iecri, i1;
    static doublereal stmin, cc, fa, fb, hh;
    static integer ii, ij, ik, jk, ni, ip, ir, np;
    static doublereal stepbd, steplb;
    extern   int majour_();
    static doublereal gl1, gl2, dga, dgb, dff;
    static integer ial, nip, itr;

     
    static cilist io___2580 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2581 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2597 = { 0, 0, 0, fmt_1010, 0 };
    static cilist io___2612 = { 0, 0, 0, fmt_1020, 0 };
    static cilist io___2613 = { 0, 0, 0, fmt_1019, 0 };
    static cilist io___2615 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2616 = { 0, 0, 0, fmt_1022, 0 };
    static cilist io___2617 = { 0, 0, 0, fmt_1023, 0 };
    static cilist io___2622 = { 0, 0, 0, fmt_1021, 0 };
    static cilist io___2623 = { 0, 0, 0, fmt_1020, 0 };
    static cilist io___2625 = { 0, 0, 0, fmt_1023, 0 };



 

     
    --gb;
    --xb;
    --ga;
    --xa;
    --w;
    --d__;
    --scale;
    --g;
    --x;
    --h__;
    --izs;
    --rzs;
    --dzs;

     
 
 
 
 
 
 
 
 
    indic = 4;
    (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
    if (indic > 0) {
	goto L13;
    }
    if (*iprint == 0) {
	goto L12;
    }
    if (indic < 0) {
	io___2580.ciunit = *lp;
	s_wsfe(&io___2580);
	e_wsfe();
    }
    if (indic == 0) {
	io___2581.ciunit = *lp;
	s_wsfe(&io___2581);
	e_wsfe();
    }
L12:
    *acc = 0.;
    *niter = 1;
    *nsim = 1;
    return 0;
L13:
    nfun = 1;
    iecri = 0;
    itr = 0;
    np = *n + 1;
 
    if (*mode >= 2) {
	goto L60;
    }
L20:
    c__ = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__2 = c__, d__3 = (d__1 = g[i__] * scale[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	c__ = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
    }
    if (c__ <= 0.) {
	c__ = 1.;
    }
    k = *n * np / 2;
    i__1 = k;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	h__[i__] = 0.;
    }
    k = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	h__[k] = c__ * .01 / (scale[i__] * scale[i__]);
 
	k = k + np - i__;
    }
    goto L100;
 
L60:
    if (*mode >= 3) {
	goto L80;
    }
    k = *n;
    if (*n > 1) {
	goto L300;
    }
    if (h__[1] > 0.) {
	goto L305;
    }
    h__[1] = 0.;
    k = 0;
    goto L305;
L300:
    np = *n + 1;
    ii = 1;
    i__1 = *n;
    for (i__ = 2; i__ <= i__1; ++i__) {
	hh = h__[ii];
	ni = ii + np - i__;
	if (hh > 0.) {
	    goto L301;
	}
	h__[ii] = 0.;
	--k;
	ii = ni + 1;
	goto L304;
L301:
	ip = ii + 1;
	ii = ni + 1;
	jk = ii;
	i__2 = ni;
	for (ij = ip; ij <= i__2; ++ij) {
	    v = h__[ij] / hh;
	    i__3 = ni;
	    for (ik = ij; ik <= i__3; ++ik) {
		h__[jk] -= h__[ik] * v;
 
		++jk;
	    }
 
	    h__[ij] = v;
	}
L304:
	;
    }
    if (h__[ii] > 0.) {
	goto L305;
    }
    h__[ii] = 0.;
    --k;
L305:

    if (k >= *n) {
	goto L100;
    }
L70:
    if (*iprint != 0) {
	io___2597.ciunit = *lp;
	s_wsfe(&io___2597);
	e_wsfe();
    }
    goto L20;
 
L80:
    k = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (h__[k] <= 0.) {
	    goto L70;
	}
 
	k = k + np - i__;
    }
 
L100:
    dff = 0.;
L110:
    fa = *f;
    isfv = 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xa[i__] = x[i__];
 
	ga[i__] = g[i__];
    }
 
L130:
    ++itr;
    ial = 0;
    if (itr > *niter) {
	goto L250;
    }
    ++iecri;
    if (iecri != -(*iprint)) {
	goto L140;
    }
    iecri = 0;
    indic = 1;
    (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
 
L140:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	d__[i__] = -ga[i__];
    }
    w[1] = d__[1];
    if (*n > 1) {
	goto L400;
    }
    d__[1] /= h__[1];
    goto L412;
L400:
    i__1 = *n;
    for (i__ = 2; i__ <= i__1; ++i__) {
	ij = i__;
	i1 = i__ - 1;
	v = d__[i__];
	i__2 = i1;
	for (j = 1; j <= i__2; ++j) {
	    v -= h__[ij] * d__[j];
 
	    ij = ij + *n - j;
	}
	w[i__] = v;
 
	d__[i__] = v;
    }
    d__[*n] /= h__[ij];
    np = *n + 1;
    i__1 = *n;
    for (nip = 2; nip <= i__1; ++nip) {
	i__ = np - nip;
	ii = ij - nip;
	v = d__[i__] / h__[ii];
	ip = i__ + 1;
	ij = ii;
	i__2 = *n;
	for (j = ip; j <= i__2; ++j) {
	    ++ii;
 
	    v -= h__[ii] * d__[j];
	}
 
	d__[i__] = v;
    }
L412:
 
 
    c__ = 0.;
    dga = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	d__2 = c__, d__3 = (d__1 = d__[i__] / scale[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	c__ = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
	dga += ga[i__] * d__[i__];
    }
 
    if (dga >= 0.) {
	goto L240;
    }
 
    stmin = 0.;
    stepbd = 0.;
    steplb = *acc / c__;
    fmin = fa;
    gmin = dga;
    step = 1.;
    if (dff <= 0.) {
 
	d__1 = step, d__2 = 1. / c__;
	step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if (dff > 0.) {
 
	d__1 = step, d__2 = (dff + dff) / (-dga);
	step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if (*iprint >= 2) {
	io___2612.ciunit = *lp;
	s_wsfe(&io___2612);
	do_fio(&c__1, (char *)&itr, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nfun, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&fa, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*iprint >= 3) {
	io___2613.ciunit = *lp;
	s_wsfe(&io___2613);
	do_fio(&c__1, (char *)&dga, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
L170:
    c__ = stmin + step;
    if (nfun >= *nsim) {
	goto L250;
    }
    ++nfun;
 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xb[i__] = xa[i__] + c__ * d__[i__];
    }
    indic = 4;
    (*simul)(&indic, n, &xb[1], &fb, &gb[1], &izs[1], &rzs[1], &dzs[1]);
 
    if (indic > 0) {
	goto L185;
    }
    if (indic < 0) {
	goto L183;
    }
    if (*iprint > 0) {
	io___2615.ciunit = *lp;
	s_wsfe(&io___2615);
	e_wsfe();
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = xb[i__];
 
	g[i__] = gb[i__];
    }
    goto L250;
L183:
    stepbd = step;
    ial = 1;
    step /= 10.;
    if (*iprint >= 3) {
	io___2616.ciunit = *lp;
	s_wsfe(&io___2616);
	do_fio(&c__1, (char *)&c__, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (stepbd > steplb) {
	goto L170;
    }
    if (*iprint != 0 && isfv < 2) {
	io___2617.ciunit = *lp;
	s_wsfe(&io___2617);
	e_wsfe();
    }
    goto L240;
 
L185:
    isfv = (( 2 ) <= ( isfv ) ? ( 2 ) : ( isfv )) ;
    if (fb > *f) {
	goto L220;
    }
    if (fb < *f) {
	goto L200;
    }
    gl1 = 0.;
    gl2 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	d__1 = scale[i__] * g[i__];
	gl1 += d__1 * d__1;
 
 
	d__1 = scale[i__] * gb[i__];
	gl2 += d__1 * d__1;
    }
    if (gl2 >= gl1) {
	goto L220;
    }
L200:
    isfv = 3;
    *f = fb;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = xb[i__];
 
	g[i__] = gb[i__];
    }
 
L220:
    dgb = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dgb += gb[i__] * d__[i__];
    }
    if (*iprint < 3) {
	goto L231;
    }
    s = fb - fa;
    io___2622.ciunit = *lp;
    s_wsfe(&io___2622);
    do_fio(&c__1, (char *)&c__, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&s, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&dgb, (ftnlen)sizeof(doublereal));
    e_wsfe();
 
L231:
    if (fb - fa <= c__ * .1 * dga) {
	goto L280;
    }
    ial = 0;
 
    if (step > steplb) {
	goto L270;
    }
L240:
    if (isfv >= 2) {
	goto L110;
    }
 
L250:
    if (*iprint > 0) {
	io___2623.ciunit = *lp;
	s_wsfe(&io___2623);
	do_fio(&c__1, (char *)&itr, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nfun, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    *acc = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	*acc += g[i__] * g[i__];
    }
    *niter = itr;
    *nsim = nfun;
    return 0;
 
L270:
    stepbd = step;
    c__ = gmin + dgb - (fb - fmin) * 3. / step;
    cc = (( c__ ) >= 0 ? ( c__ ) : -( c__ ))  - gmin * (dgb / (( c__ ) >= 0 ? ( c__ ) : -( c__ )) );
    cc = sqrt(((( c__ ) >= 0 ? ( c__ ) : -( c__ )) )) * sqrt(((( 0. ) >= ( cc ) ? ( 0. ) : ( cc )) ));
    c__ = (c__ - gmin + cc) / (dgb - gmin + cc + cc);
    step *= (( .1 ) >= ( c__ ) ? ( .1 ) : ( c__ )) ;
    goto L170;
 
L280:
    if (ial == 0) {
	goto L285;
    }
    if (stepbd > steplb) {
	goto L285;
    }
    if (*iprint != 0 && isfv < 2) {
	io___2625.ciunit = *lp;
	s_wsfe(&io___2625);
	e_wsfe();
    }
    goto L240;
L285:
    stepbd -= step;
    stmin = c__;
    fmin = fb;
    gmin = dgb;
 
    step = stmin * 9.;
    if (stepbd > 0.) {
	step = stepbd * .5;
    }
    c__ = dga + dgb * 3. - (fb - fa) * 4. / stmin;
    if (c__ > 0.) {
 
 
	d__3 = 1., d__4 = -dgb / c__;
	d__1 = step, d__2 = stmin * (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
	step = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    if (dgb < dga * .7) {
	goto L170;
    }
 
    isfv = 4 - isfv;
    if (stmin + step <= steplb) {
	goto L240;
    }
 
    ir = -(*n);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xa[i__] = xb[i__];
	xb[i__] = ga[i__];
	d__[i__] = gb[i__] - ga[i__];
 
	ga[i__] = gb[i__];
    }
    d__1 = 1. / dga;
    majour_(&h__[1], &xb[1], &w[1], n, &d__1, &ir, &c__1, &c_b61);
    ir = -ir;
    d__1 = 1. / (stmin * (dgb - dga));
    majour_(&h__[1], &d__[1], &d__[1], n, &d__1, &ir, &c__1, &c_b61);
 
    if (ir < *n) {
	goto L250;
    }
 
    dff = fa - fb;
    fa = fb;
    goto L130;
}  

  int n1qn2_(simul, prosca, n, x, f, g, dxmin, df1, epsg, 
	impres, io, mode, niter, nsim, dz, ndz, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *x, *f, *g, *dxmin, *df1, *epsg;
integer *impres, *io, *mode, *niter, *nsim;
doublereal *dz;
integer *ndz, *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_900[] = "(/,\002 n1qn2: point d'entree\002,/,5x,\002dimension du probleme (n)              :\002,i6,/,5x,\002precision absolue en x (dxmin)         :\002,d9.2,/,5x,\002decroissance attendue pour f (df1)     :\002,d9.2,/,5x,\002precision relative en g (epsg)         :\002,d9.2,/,5x,\002nombre maximal d'iterations (niter)    :\002,i6,/,5x,\002nombre maximal d'appels a simul (nsim) :\002,i6,/,5x,\002niveau d'impression (impres)           :\002,i4)";
    static char fmt_901[] = "(/,\002 >>> n1qn2 : appel incoherent\002)";
    static char fmt_902[] = "(/,\002 >>> n1qn2: memoire allouee insuffisante\002)";
    static char fmt_903[] = "(/5x,\002memoire allouee (ndz)  :\002,i7,/,5x,\002memoire utilisee       :\002,i7,/,5x,\002nombre de mises a jour :\002,i6,/)";
    static char fmt_905[] = "(/,1x,79(\002-\002),/,/,1x,\002n1qn2 : sortie en mode \002,i2,/,5x,\002nombre d'iterations              : \002,i4,/,5x,\002nombre d'appels a simul          : \002,i6,/,5x,\002precision relative atteinte sur g: \002,d9.2)";
    static char fmt_906[] = "(5x,\002norme de x = \002,d15.8,/,5x,\002f          = \002,d15.8,/,5x,\002norme de g = \002,d15.8)";

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static integer iaux, ndzu, m, isbar;
    extern   int n1qn2a_();
    static integer iybar;
    static doublereal r1, r2;
    static integer l1memo, id, ialpha;
    static doublereal ps;
    static integer igg;

     
    static cilist io___2627 = { 0, 0, 0, fmt_900, 0 };
    static cilist io___2628 = { 0, 0, 0, fmt_901, 0 };
    static cilist io___2629 = { 0, 0, 0, fmt_902, 0 };
    static cilist io___2633 = { 0, 0, 0, fmt_903, 0 };
    static cilist io___2640 = { 0, 0, 0, fmt_905, 0 };
    static cilist io___2644 = { 0, 0, 0, fmt_906, 0 };

     
    --dzs;
    --rzs;
    --izs;
    --dz;
    --g;
    --x;

     
    if (*impres >= 1) {
	io___2627.ciunit = *io;
	s_wsfe(&io___2627);
	do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*dxmin), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*df1), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*impres), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*n <= 0 || *niter <= 0 || *nsim <= 0 || *dxmin <= 0. || *epsg <= 0. ||
	     *epsg > 1.) {
	*mode = 2;
	if (*impres >= 1) {
	    io___2628.ciunit = *io;
	    s_wsfe(&io___2628);
	    e_wsfe();
	}
	goto L904;
    }
    if (*ndz < *n * 5 + 1) {
	*mode = 2;
	if (*impres >= 1) {
	    io___2629.ciunit = *io;
	    s_wsfe(&io___2629);
	    e_wsfe();
	}
	goto L904;
    }

 

    ndzu = *ndz - *n * 3;
    l1memo = (*n << 1) + 1;
    m = ndzu / l1memo;
    ndzu = m * l1memo + *n * 3;
    if (*impres >= 1) {
	io___2633.ciunit = *io;
	s_wsfe(&io___2633);
	do_fio(&c__1, (char *)&(*ndz), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&ndzu, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    id = 1;
    igg = id + *n;
    iaux = igg + *n;
    ialpha = iaux + *n;
    iybar = ialpha + m;
    isbar = iybar + *n * m;

 

    n1qn2a_(simul, prosca, n, &x[1], f, &g[1], dxmin, df1, epsg, impres, io, 
	    mode, niter, nsim, &m, &dz[id], &dz[igg], &dz[iaux], &dz[ialpha], 
	    &dz[iybar], &dz[isbar], &izs[1], &rzs[1], &dzs[1]);

 

L904:
    if (*impres >= 1) {
	io___2640.ciunit = *io;
	s_wsfe(&io___2640);
	do_fio(&c__1, (char *)&(*mode), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*niter), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nsim), (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    (*prosca)(n, &x[1], &x[1], &ps, &izs[1], &rzs[1], &dzs[1]);
    r1 = sqrt(ps);
    (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]);
    r2 = sqrt(ps);
    if (*impres >= 1) {
	io___2644.ciunit = *io;
	s_wsfe(&io___2644);
	do_fio(&c__1, (char *)&r1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&r2, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

    return 0;
}  

  int n1qn2a_(simul, prosca, n, x, f, g, dxmin, df1, epsg, 
	impres, io, mode, niter, nsim, m, d__, gg, aux, alpha, ybar, sbar, 
	izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *x, *f, *g, *dxmin, *df1, *epsg;
integer *impres, *io, *mode, *niter, *nsim, *m;
doublereal *d__, *gg, *aux, *alpha, *ybar, *sbar;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_900[] = "(5x,\002f          = \002,d15.8,/,5x,\002norme de g = \002,d15.8)";
    static char fmt_899[] = "(/,\002 n1qn2a: direction de descente -g: precon = \002,d10.3)";
    static char fmt_901[] = "(/,1x,79(\002-\002))";
    static char fmt_9010[] = "(1x)";
    static char fmt_902[] = "(\002 n1qn2: iter \002,i3,\002, simul \002,i3,\002, f=\002,d15.8,\002, h'(0)=\002,d12.5)";
    static char fmt_903[] = "(/,\002 n1qn2: recherche lineaire\002)";
    static char fmt_904[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): recherche lineaire bloquee sur tmax: \002,\002reduire l'echelle\002)";
    static char fmt_905[] = "(/,\002 n1qn2: test d'arret sur g: \002,d12.5)";
    static char fmt_906[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): nombre maximal d'iterations atteint\002)";
    static char fmt_907[] = "(/,\002 >>> n1qn2 (iteration \002,i3,\002): \002,i6,\002 appels a simul (nombre maximal atteint)\002)";
    static char fmt_908[] = "(/,\002 >>> n1qn2 (iteration \002,i2,\002): le produit scalaire (y,s) = \002,d12.5,/,27x,\002n'est pas positif\002)";
    static char fmt_909[] = "(/,\002 n1qn2: mise a jour: (y,s) = \002,d10.3,\002 Oren-Spedicato = \002,d10.3)";
    static char fmt_910[] = "(/,\002 >>> n1qn2 (iteration \002,i2,\002): \002,/,5x,\002la direction de recherche d n'est pas de \002,\002descente: (g,d) = \002,d12.5)";
    static char fmt_911[] = "(/,\002 n1qn2: direction de descente d: \002,\002angle(-g,d) = \002,f5.1,\002 degres\002)";

     
    integer ybar_dim1, ybar_offset, sbar_dim1, sbar_offset, i__1;
    doublereal d__1, d__2, d__3;

     
    double sqrt();
    integer s_wsfe(), do_fio(), e_wsfe();
    double acos();

     
    static integer jmin, jmax, isim, iter;
    static doublereal tmin, tmax;
    extern   int nlis0_();
    static integer i__;
    static real r__;
    static doublereal t;
    static integer indic;
    static doublereal gnorm, d1, ff, ps;
    static integer moderl;
    static doublereal precon;
    extern   int strang_();
    static doublereal hp0, ps2, eps1;

     
    static cilist io___2649 = { 0, 0, 0, fmt_900, 0 };
    static cilist io___2652 = { 0, 0, 0, fmt_899, 0 };
    static cilist io___2653 = { 0, 0, 0, fmt_901, 0 };
    static cilist io___2654 = { 0, 0, 0, fmt_9010, 0 };
    static cilist io___2655 = { 0, 0, 0, fmt_901, 0 };
    static cilist io___2661 = { 0, 0, 0, fmt_901, 0 };
    static cilist io___2662 = { 0, 0, 0, fmt_9010, 0 };
    static cilist io___2663 = { 0, 0, 0, fmt_902, 0 };
    static cilist io___2665 = { 0, 0, 0, fmt_903, 0 };
    static cilist io___2670 = { 0, 0, 0, fmt_904, 0 };
    static cilist io___2672 = { 0, 0, 0, fmt_905, 0 };
    static cilist io___2673 = { 0, 0, 0, fmt_906, 0 };
    static cilist io___2674 = { 0, 0, 0, fmt_907, 0 };
    static cilist io___2675 = { 0, 0, 0, fmt_908, 0 };
    static cilist io___2676 = { 0, 0, 0, fmt_909, 0 };
    static cilist io___2677 = { 0, 0, 0, fmt_910, 0 };
    static cilist io___2680 = { 0, 0, 0, fmt_911, 0 };


 

 

 

 


 


 


 

     
    --aux;
    --gg;
    --d__;
    --g;
    --x;
    sbar_dim1 = *n;
    sbar_offset = sbar_dim1 + 1;
    sbar -= sbar_offset;
    ybar_dim1 = *n;
    ybar_offset = ybar_dim1 + 1;
    ybar -= ybar_offset;
    --alpha;
    --izs;
    --rzs;
    --dzs;

     
    iter = 0;
    isim = 1;
    (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]);
    gnorm = sqrt(ps);
    if (*impres >= 1) {
	io___2649.ciunit = *io;
	s_wsfe(&io___2649);
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&gnorm, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 
 

 
    d__1 = gnorm;
    precon = *df1 * 2. / (d__1 * d__1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__[i__] = -g[i__] * precon;
 
    }
    if (*impres >= 5) {
	io___2652.ciunit = *io;
	s_wsfe(&io___2652);
	do_fio(&c__1, (char *)&precon, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*impres == 3) {
	io___2653.ciunit = *io;
	s_wsfe(&io___2653);
	e_wsfe();
	io___2654.ciunit = *io;
	s_wsfe(&io___2654);
	e_wsfe();
    }
    if (*impres == 4) {
	io___2655.ciunit = *io;
	s_wsfe(&io___2655);
	e_wsfe();
    }

 

    tmax = 1e20;
    (*prosca)(n, &d__[1], &g[1], &hp0, &izs[1], &rzs[1], &dzs[1]);

 

    jmin = 1;
    jmax = 0;

 
 

 
 

L100:
    ++iter;
    if (*impres < 0) {
	if (iter % (-(*impres)) == 0) {
	    indic = 1;
	    (*simul)(&indic, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
	    goto L100;
	}
    }
    if (*impres >= 5) {
	io___2661.ciunit = *io;
	s_wsfe(&io___2661);
	e_wsfe();
    }
    if (*impres >= 4) {
	io___2662.ciunit = *io;
	s_wsfe(&io___2662);
	e_wsfe();
    }
    if (*impres >= 3) {
	io___2663.ciunit = *io;
	s_wsfe(&io___2663);
	do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&isim, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&hp0, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	gg[i__] = g[i__];
 
    }
    ff = *f;

 

    if (*impres >= 5) {
	io___2665.ciunit = *io;
	s_wsfe(&io___2665);
	e_wsfe();
    }

 

    tmin = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	d__2 = tmin, d__3 = (d__1 = d__[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	tmin = (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ;
 
    }
    tmin = *dxmin / tmin;
    t = 1.;
    d1 = hp0;

    nlis0_(n, simul, prosca, &x[1], f, &d1, &t, &tmin, &tmax, &d__[1], &g[1], 
	    &c_b5732, &c_b5340, impres, io, &moderl, &isim, nsim, &aux[1], &
	    izs[1], &rzs[1], &dzs[1]);

 

    if (moderl != 0) {
	if (moderl < 0) {

 
 
 

	    *mode = moderl;
	} else if (moderl == 1) {

 
 

	    *mode = 3;
	    if (*impres >= 1) {
		io___2670.ciunit = *io;
		s_wsfe(&io___2670);
		do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
		e_wsfe();
	    }
	} else if (moderl == 4) {

 
 

	    *mode = 5;
	} else if (moderl == 5) {

 
 

	    *mode = 0;
	} else if (moderl == 6) {

 
 

	    *mode = 6;
	}
	goto L1000;
    }

 

    (*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]);
    eps1 = sqrt(ps) / gnorm;

    if (*impres >= 5) {
	io___2672.ciunit = *io;
	s_wsfe(&io___2672);
	do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (eps1 < *epsg) {
	*mode = 1;
	goto L1000;
    }
    if (iter == *niter) {
	*mode = 4;
	if (*impres >= 1) {
	    io___2673.ciunit = *io;
	    s_wsfe(&io___2673);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	goto L1000;
    }
    if (isim >= *nsim) {
	*mode = 5;
	if (*impres >= 1) {
	    io___2674.ciunit = *io;
	    s_wsfe(&io___2674);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&isim, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	goto L1000;
    }

 

    ++jmax;
    if (iter > *m) {
	++jmin;
	if (jmin > *m) {
	    jmin -= *m;
	}
	if (jmax > *m) {
	    jmax -= *m;
	}
    }

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sbar[i__ + jmax * sbar_dim1] = t * d__[i__];
	ybar[i__ + jmax * ybar_dim1] = g[i__] - gg[i__];
 
    }
    (*prosca)(n, &ybar[jmax * ybar_dim1 + 1], &sbar[jmax * sbar_dim1 + 1], &
	    d1, &izs[1], &rzs[1], &dzs[1]);
    if (d1 <= 0.) {
	*mode = 7;
	if (*impres >= 1) {
	    io___2675.ciunit = *io;
	    s_wsfe(&io___2675);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&d1, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	goto L1000;
    }

 

    (*prosca)(n, &ybar[jmax * ybar_dim1 + 1], &ybar[jmax * ybar_dim1 + 1], &
	    ps, &izs[1], &rzs[1], &dzs[1]);
    precon = d1 / ps;
    if (*impres >= 5) {
	io___2676.ciunit = *io;
	s_wsfe(&io___2676);
	do_fio(&c__1, (char *)&d1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&precon, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 

    d1 = sqrt(1. / d1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	sbar[i__ + jmax * sbar_dim1] = d1 * sbar[i__ + jmax * sbar_dim1];
	ybar[i__ + jmax * ybar_dim1] = d1 * ybar[i__ + jmax * ybar_dim1];
 
    }

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__[i__] = -g[i__];
 
    }
    strang_(prosca, n, m, &d__[1], &jmin, &jmax, &precon, &alpha[1], &ybar[
	    ybar_offset], &sbar[sbar_offset], &izs[1], &rzs[1], &dzs[1]);

 
 

    (*prosca)(n, &d__[1], &g[1], &hp0, &izs[1], &rzs[1], &dzs[1]);
    if (hp0 >= 0.) {
	*mode = 7;
	if (*impres >= 1) {
	    io___2677.ciunit = *io;
	    s_wsfe(&io___2677);
	    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&hp0, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	goto L1000;
    }
    if (*impres >= 5) {
	(*prosca)(n, &g[1], &g[1], &ps, &izs[1], &rzs[1], &dzs[1]);
	ps = sqrt(ps);
	(*prosca)(n, &d__[1], &d__[1], &ps2, &izs[1], &rzs[1], &dzs[1]);
	ps2 = sqrt(ps2);
	ps = hp0 / ps / ps2;
 
	d__1 = -ps;
	ps = (( d__1 ) <= ( 1. ) ? ( d__1 ) : ( 1. )) ;
	ps = acos(ps);
	r__ = (real) (ps * (float)180. / 3.1415927);
	io___2680.ciunit = *io;
	s_wsfe(&io___2680);
	do_fio(&c__1, (char *)&r__, (ftnlen)sizeof(real));
	e_wsfe();
    }

 

    goto L100;

 

L1000:
    *epsg = eps1;
    *niter = iter;
    *nsim = isim;
    return 0;
}  

  int nlis0_(n, simul, prosca, xn, fn, fpn, t, tmin, tmax, d__,
	 g, amd, amf, imp, io, logic, nap, napmax, x, izs, rzs, dzs)
integer *n;
  int (*simul) (), (*prosca) ();
doublereal *xn, *fn, *fpn, *t, *tmin, *tmax, *d__, *g, *amd, *amf;
integer *imp, *io, *logic, *nap, *napmax;
doublereal *x;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1000[] = "(/,4x,\002 nlis0       fpn=\002,d10.3,\002 d2=\002,d9.2,\002  tmin=\002,d9.2,\002 tmax=\002,d9.2)";
    static char fmt_1001[] = "(/,4x,\002 nlis0\002,3x,\002fin sur tmin\002,8x,\002pas\002,12x,\002fonctions\002,5x,\002derivees\002)";
    static char fmt_1002[] = "(4x,\002 nlis0\002,37x,d10.3,2d11.3)";
    static char fmt_1003[] = "(4x,\002 nlis0\002,d14.3,2d11.3)";
    static char fmt_1004[] = "(4x,\002 nlis0\002,37x,d10.3,\002 indic=\002,i3)";
    static char fmt_1005[] = "(4x,\002 nlis0\002,14x,2d18.8,d11.3)";
    static char fmt_1006[] = "(4x,\002 nlis0\002,14x,d18.8,\002      indic=\002,i3)";
    static char fmt_1007[] = "(/,4x,\002 nlis0\002,10x,\002tmin force a tmax\002)";

     
    integer i__1;
    doublereal d__1, d__2, d__3, d__4;

     
    integer s_wsfe(), e_wsfe(), do_fio();
    double sqrt();

     
    static doublereal tesd, tesf, test, f;
    static integer i__, indic;
    static doublereal z__, d2, z1, fa, fd, fg, ta, fp;
    static integer indica;
    static doublereal td;
    static integer indicd;
    static doublereal tg, fpa, ffn, fpd, fpg;

     
    static cilist io___2691 = { 0, 0, 0, fmt_1007, 0 };
    static cilist io___2693 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2698 = { 0, 0, 0, fmt_1004, 0 };
    static cilist io___2703 = { 0, 0, 0, fmt_1002, 0 };
    static cilist io___2704 = { 0, 0, 0, fmt_1003, 0 };
    static cilist io___2708 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2709 = { 0, 0, 0, fmt_1005, 0 };
    static cilist io___2710 = { 0, 0, 0, fmt_1005, 0 };
    static cilist io___2711 = { 0, 0, 0, fmt_1006, 0 };


 

 
 

 

 
 
 
 
 
 

 

 


 


     
    --x;
    --g;
    --d__;
    --xn;
    --izs;
    --rzs;
    --dzs;

     
 
 
 
 
 
 
 
 
 
    if (*n > 0 && *fpn < 0. && *t > 0. && *tmax > 0. && *amf > 0. && *amd > *
	    amf && *amd < 1.) {
	goto L5;
    }
    *logic = 6;
    goto L999;
L5:
    tesf = *amf * *fpn;
    tesd = *amd * *fpn;
    td = 0.;
    tg = 0.;
    fg = *fn;
    fpg = *fpn;
    ta = 0.;
    fa = *fn;
    fpa = *fpn;
    (*prosca)(n, &d__[1], &d__[1], &d2, &izs[1], &rzs[1], &dzs[1]);

 

    if (*t > *tmin) {
	goto L20;
    }
    *t = *tmin;
    if (*t <= *tmax) {
	goto L20;
    }
    if (*imp > 0) {
	io___2691.ciunit = *io;
	s_wsfe(&io___2691);
	e_wsfe();
    }
    *tmin = *tmax;
L20:
    if (*fn + *t * *fpn < *fn + *t * .9 * *fpn) {
	goto L30;
    }
    *t *= 2.;
    goto L20;
L30:
    indica = 1;
    *logic = 0;
    if (*t > *tmax) {
	*t = *tmax;
	*logic = 1;
    }
    if (*imp >= 4) {
	io___2693.ciunit = *io;
	s_wsfe(&io___2693);
	do_fio(&c__1, (char *)&(*fpn), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&d2, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*tmin), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = xn[i__] + *t * d__[i__];
 
    }

 

L100:
    ++(*nap);
    if (*nap > *napmax) {
	*logic = 4;
	*fn = fg;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    xn[i__] += tg * d__[i__];
 
	}
	goto L999;
    }
    indic = 4;

 

    (*simul)(&indic, n, &x[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]);
    if (indic == 0) {

 

	*logic = 5;
	*fn = f;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    xn[i__] = x[i__];
 
	}
	goto L999;
    }
    if (indic < 0) {

 


	td = *t;
	indicd = indic;
	*logic = 0;
	if (*imp >= 4) {
	    io___2698.ciunit = *io;
	    s_wsfe(&io___2698);
	    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	    do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*t = tg + (td - tg) * .1;
	goto L905;
    }

 

    (*prosca)(n, &d__[1], &g[1], &fp, &izs[1], &rzs[1], &dzs[1]);

 

    ffn = f - *fn;
    if (ffn > *t * tesf) {
	td = *t;
	fd = f;
	fpd = fp;
	indicd = indic;
	*logic = 0;
	if (*imp >= 4) {
	    io___2703.ciunit = *io;
	    s_wsfe(&io___2703);
	    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	    do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal));
	    do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	goto L500;
    }

 

    if (*imp >= 4) {
	io___2704.ciunit = *io;
	s_wsfe(&io___2704);
	do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (fp > tesd) {
	*logic = 0;
	goto L320;
    }
    if (*logic == 0) {
	goto L350;
    }

 

L320:
    *fn = f;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xn[i__] = x[i__];
 
    }
    goto L999;



L350:
    tg = *t;
    fg = f;
    fpg = fp;
    if (td != 0.) {
	goto L500;
    }

 

    ta = *t;
    *t = tg * 9.;
    z__ = *fpn + fp * 3. - ffn * 4. / tg;
    if (z__ > 0.) {
 
 
	d__3 = 1., d__4 = -fp / z__;
	d__1 = *t, d__2 = tg * (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
	*t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    *t = tg + *t;
    if (*t < *tmax) {
	goto L900;
    }
    *logic = 1;
    *t = *tmax;
    goto L900;

 

L500:
    if (indica <= 0) {
	ta = *t;
	*t = tg * .9 + td * .1;
	goto L900;
    }
    z__ = fp + fpa - (fa - f) * 3. / (ta - *t);
    z1 = z__ * z__ - fp * fpa;
    if (z1 < 0.) {
	ta = *t;
	*t = (td + tg) * .5;
	goto L900;
    }
    if (*t < ta) {
	z1 = z__ - sqrt(z1);
    }
    if (*t > ta) {
	z1 = z__ + sqrt(z1);
    }
    z__ = fp / (fp + z1);
    z__ = *t + z__ * (ta - *t);
    ta = *t;
    test = (td - tg) * .1;
 
    d__1 = z__, d__2 = tg + test;
    *t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    d__1 = *t, d__2 = td - test;
    *t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;

 
 
 

L900:
    fa = f;
    fpa = fp;
L905:
    indica = indic;

 

    if (td == 0.) {
	goto L950;
    }
    if (td - tg < *tmin) {
	goto L920;
    }

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z__ = xn[i__] + *t * d__[i__];
	if (z__ != xn[i__] && z__ != x[i__]) {
	    goto L950;
	}
 
    }

 

L920:
    *logic = 6;

 


    if (indicd < 0) {
	*logic = indicd;
    }

 
 

    if (tg == 0.) {
	goto L940;
    }
    *fn = fg;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] += tg * d__[i__];
    }
L940:
    if (*imp <= 0) {
	goto L999;
    }
    io___2708.ciunit = *io;
    s_wsfe(&io___2708);
    e_wsfe();
    io___2709.ciunit = *io;
    s_wsfe(&io___2709);
    do_fio(&c__1, (char *)&tg, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&fg, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&fpg, (ftnlen)sizeof(doublereal));
    e_wsfe();
    if (*logic == 6) {
	io___2710.ciunit = *io;
	s_wsfe(&io___2710);
	do_fio(&c__1, (char *)&td, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&fd, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&fpd, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*logic == 7) {
	io___2711.ciunit = *io;
	s_wsfe(&io___2711);
	do_fio(&c__1, (char *)&td, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&indicd, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    goto L999;

 

L950:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x[i__] = xn[i__] + *t * d__[i__];
    }
    goto L100;
L999:
    return 0;
}  

  int nlis2_(simul, prosca, n, xn, fn, fpn, t, tmin, tmax, d__,
	 d2, g, gd, amd, amf, imp, io, logic, nap, napmax, x, tol, a, tps, 
	tnc, gg, izs, rzs, dzs)
  int (*simul) (), (*prosca) ();
integer *n;
doublereal *xn, *fn, *fpn, *t, *tmin, *tmax, *d__, *d2, *g, *gd, *amd, *amf;
integer *imp, *io, *logic, *nap, *napmax;
doublereal *x, *tol, *a, *tps, *tnc, *gg;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1000[] = "(/4x,\002 nlis2   \002,4x,\002fpn=\002,d10.3,\002 d2=\002,d9.2,\002  tmin=\002,d9.2,\002 tmax=\002,d9.2)";
    static char fmt_1001[] = "(/4x,\002 nlis2\002,10x,\002tmin force a tmax\002)";
    static char fmt_1002[] = "(4x,\002 nlis2\002,36x,\002i\002,d10.3,2d11.3)";
    static char fmt_1003[] = "(4x,\002 nlis2\002,d13.3,2d11.3,\002 i\002)";
    static char fmt_1004[] = "(4x,\002 nlis2\002,36x,\002i\002,d10.3,\002 indic=\002,i3)";
    static char fmt_1006[] = "(4x,\002 nlis2\002,3x,\002contrainte implicite\002,i4,\002 active\002)";
    static char fmt_1007[] = "(/4x,\002 nlis2\002,3x,\002fin sur tmin\002)";
    static char fmt_1010[] = "(/4x,\002 nlis2\002,3x,i5,\002 simulations atteintes\002)";
    static char fmt_1011[] = "(/4x,\002 nlis2\002,3x,\002arret demande par l'utilisateur\002)";

     
    integer i__1;
    doublereal d__1;

     
    integer s_wsfe(), e_wsfe(), do_fio();

     
    static doublereal tesd, tesf, step, f;
    static integer i__;
    static doublereal p, s;
    static integer indic;
    static doublereal z__;
    static integer inout;
    static doublereal fa, fd, fg, hh, ta, fp;
    static integer indica;
    static doublereal td;
    static integer indicd;
    static doublereal tg, cx, cy, fx, gx, fy, gy, cz, fz, gz;
    static integer iyflag;
    static doublereal tx, ty, sthalf, penlty, ggg, fpa, ffn, fpd, fpg;
    extern   int fpq2_();

     
    static cilist io___2729 = { 0, 0, 0, fmt_1001, 0 };
    static cilist io___2730 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2744 = { 0, 0, 0, fmt_1010, 0 };
    static cilist io___2747 = { 0, 0, 0, fmt_1011, 0 };
    static cilist io___2749 = { 0, 0, 0, fmt_1004, 0 };
    static cilist io___2754 = { 0, 0, 0, fmt_1002, 0 };
    static cilist io___2756 = { 0, 0, 0, fmt_1003, 0 };
    static cilist io___2758 = { 0, 0, 0, fmt_1006, 0 };
    static cilist io___2759 = { 0, 0, 0, fmt_1007, 0 };


 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 

 


 

     
    --gg;
    --x;
    --gd;
    --g;
    --d__;
    --xn;
    --izs;
    --rzs;
    --dzs;

     
 
 
 
 
 
 
 
 
 
    tesf = *amf * *fpn;
    tesd = *amd * *fpn;
    td = 0.;
    tg = 0.;
    fg = *fn;
    fpg = *fpn;
    ta = 0.;
    fa = *fn;
    fpa = *fpn;
    indica = 1;
    *logic = 0;
    tx = 0.;
    cx = 0.;
    fx = *fn;
    gx = *fpn;
    step = *t;
    sthalf = (float).1;
    penlty = 0.;
 
    if (*t > *tmin) {
	goto L20;
    }
    *t = *tmin;
    if (*t <= *tmax) {
	goto L20;
    }
    if (*imp > 0) {
	io___2729.ciunit = *io;
	s_wsfe(&io___2729);
	e_wsfe();
    }
    *tmin = *tmax;
L20:
    if (*fn + *t * *fpn < *fn + *t * .9 * *fpn) {
	goto L30;
    }
    *t *= 2.;
    goto L20;

L30:
    if (*t < *tmax) {
	goto L40;
    }
    *t = *tmax;
    *logic = 1;
L40:
    if (*imp >= 4) {
	io___2730.ciunit = *io;
	s_wsfe(&io___2730);
	do_fio(&c__1, (char *)&(*fpn), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*d2), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*tmin), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x[i__] = xn[i__] + *t * d__[i__];
    }
    inout = 0;
    fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, &
	    cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s);

 

L100:
    ++(*nap);
    if (*nap <= *napmax) {
	goto L150;
    }
 
    *logic = 4;
    if (*imp >= 4) {
	io___2744.ciunit = *io;
	s_wsfe(&io___2744);
	do_fio(&c__1, (char *)&(*nap), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (tg == 0.) {
	goto L999;
    }
    *fn = fg;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	g[i__] = gg[i__];
 
	xn[i__] += tg * d__[i__];
    }
    goto L999;
L150:
    indic = 4;
    (*simul)(&indic, n, &x[1], &f, &g[1], &izs[1], &rzs[1], &dzs[1]);
    if (indic != 0) {
	goto L200;
    }

 
    *logic = 5;
    *fn = f;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] = x[i__];
    }
    if (*imp >= 4) {
	io___2747.ciunit = *io;
	s_wsfe(&io___2747);
	e_wsfe();
    }
    goto L999;

 
 

L200:
    if (indic > 0) {
	goto L210;
    }
    td = *t;
    indicd = indic;
    *logic = 0;
    if (*imp >= 4) {
	io___2749.ciunit = *io;
	s_wsfe(&io___2749);
	do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    *t = tg + (td - tg) * .1;
    goto L905;

 

L210:
    (*prosca)(n, &d__[1], &g[1], &fp, &izs[1], &rzs[1], &dzs[1]);

 
    ffn = f - *fn;
    if (ffn <= *t * tesf) {
	goto L300;
    }
    td = *t;
    fd = f;
    fpd = fp;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	gd[i__] = g[i__];
    }
    indicd = indic;
    *logic = 0;
    cz = ffn - *t * tesf;
    fz = f;
    gz = fp;
    if (*imp >= 4) {
	io___2754.ciunit = *io;
	s_wsfe(&io___2754);
	do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (tg != 0.) {
	goto L500;
    }
 
    if (fpd < tesd) {
	goto L500;
    }
    *tps = *fn - f + td * fpd;
    *tnc = *d2 * td * td;
 
    d__1 = *a * *tnc;
    p = (( d__1 ) >= ( *tps ) ? ( d__1 ) : ( *tps )) ;
    if (p > *tol) {
	goto L500;
    }
    *logic = 3;
    goto L999;

 
L300:
    if (*imp >= 4) {
	io___2756.ciunit = *io;
	s_wsfe(&io___2756);
	do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&ffn, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&fp, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 
    if (fp < tesd) {
	goto L320;
    }

 
    *logic = 0;
    *fn = f;
    *fpn = fp;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] = x[i__];
    }
    goto L999;

L320:
    if (*logic == 0) {
	goto L350;
    }

 
    *fn = f;
    *fpn = fp;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] = x[i__];
    }
    goto L999;

 
L350:
    tg = *t;
    fg = f;
    fpg = fp;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	gg[i__] = g[i__];
    }
    cz = 0.;
    fz = f;
    gz = fp;

    if (td != 0.) {
	goto L500;
    }
 
    fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, &
	    cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s);
    if (*t < *tmax) {
	goto L900;
    }
    *logic = 1;
    *t = *tmax;
    goto L900;

 

L500:
    fpq2_(&inout, &tx, &cx, &fx, &gx, &step, &sthalf, &penlty, &iyflag, &ty, &
	    cy, &fy, &gy, t, &cz, &fz, &gz, &ggg, &hh, &s);

 

L900:
    fa = f;
    fpa = fp;
L905:
    indica = indic;
 
    if (td == 0.) {
	goto L920;
    }
    if (indicd < 0) {
	goto L920;
    }
    if (td - tg > *tmin * 10.) {
	goto L920;
    }
    if (fpd < tesd) {
	goto L920;
    }
    *tps = fg - fd + (td - tg) * fpd;
    *tnc = *d2 * (td - tg) * (td - tg);
 
    d__1 = *a * *tnc;
    p = (( d__1 ) >= ( *tps ) ? ( d__1 ) : ( *tps )) ;
    if (p > *tol) {
	goto L920;
    }
 
    *logic = 2;
    *fn = fg;
    *fpn = fpg;
    *t = tg;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xn[i__] += tg * d__[i__];
 
	g[i__] = gg[i__];
    }
    goto L999;

 

L920:
    if (td == 0.) {
	goto L990;
    }
    if (td - tg <= *tmin) {
	goto L950;
    }
    if ((d__1 = ty - tx, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= *tmin) {
	goto L950;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	z__ = xn[i__] + *t * d__[i__];
	if (z__ != x[i__] && z__ != xn[i__]) {
	    goto L990;
	}
 
    }
 
L950:
    *logic = 6;
    if (indicd < 0) {
	*logic = indicd;
    }
    if (tg == 0.) {
	goto L970;
    }
    *fn = fg;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xn[i__] += tg * d__[i__];
 
	g[i__] = gg[i__];
    }
L970:
    if (*imp <= 0) {
	goto L999;
    }
    if (*logic < 0) {
	io___2758.ciunit = *io;
	s_wsfe(&io___2758);
	do_fio(&c__1, (char *)&(*logic), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*logic == 6) {
	io___2759.ciunit = *io;
	s_wsfe(&io___2759);
	e_wsfe();
    }
    goto L999;

 
L990:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x[i__] = xn[i__] + *t * d__[i__];
    }
    goto L100;

L999:
    return 0;
}  

  int nvkt03_(a, ia, c__, ic, g, v, w, ipvt, dnorma, n, m, mi1,
	 mi, nmd, ndf)
doublereal *a;
integer *ia;
doublereal *c__;
integer *ic;
doublereal *g, *v, *w;
integer *ipvt;
doublereal *dnorma;
integer *n, *m, *mi1, *mi, *nmd, *ndf;
{
     
    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;

     
    extern doublereal ddot_(), dnrm2_();
    static integer i__, j, m1, ij, ni, mi2;
    extern   int dadd_();


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 

 

 

 


 

 

 


 

 

 

 

 
 

 

 

 

 


 
 
 

 
 

     
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    c_dim1 = *ic;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --g;
    --v;
    --w;
    --ipvt;

     
    m1 = *m + 1;
    mi2 = *mi1 + 1;
    ni = *mi - *n;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *mi1;
	for (j = 1; j <= i__2; ++j) {
 
	    w[j] = c__[i__ + ipvt[j] * c_dim1];
	}
	i__2 = *m;
	for (j = mi2; j <= i__2; ++j) {
	    ij = ipvt[j];
	    if (ij < 0) {
		if (i__ == -ij) {
		    w[j] = -1.;
		} else {
		    w[j] = 0.;
		}
	    } else if (ij <= *n) {
		if (i__ == ij) {
		    w[j] = 1.;
		} else {
		    w[j] = 0.;
		}
	    } else if (ij <= *nmd) {
		w[j] = c__[i__ + (ij + ni) * c_dim1];
	    } else if (ij < *ndf) {
		w[j] = a[i__ + (ij - *nmd) * a_dim1];
	    }
 
	}
	w[*m + i__] = ddot_(m, &w[1], &c__1, &v[1], &c__1);
 
    }
    dadd_(n, &g[1], &c__1, &w[m1], &c__1);
    *dnorma = dnrm2_(n, &w[m1], &c__1);
}  

  int optr01_(c__, ic, q, iq, r__, ir, ci, cs, b, x, w, ipvt, 
	ire, ira, n, m, mi, mi1, md, ind, imp, io, modo)
doublereal *c__;
integer *ic;
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *ci, *cs, *b, *x, *w;
integer *ipvt, *ire, *ira, *n, *m, *mi, *mi1, *md, *ind, *imp, *io, *modo;
{
     
    static char fmt_1000[] = "(/,80(\002*\002),/,10x,a,/,10x,a)";
    static char fmt_2000[] = "(/,80(\002*\002),/,10x,a,/,10x,a,i5)";
    static char fmt_3000[] = "(/,80(\002*\002),/,10x,\002THE INDEPENDENT LINEAR EQUALITY CONSTRAINTS ARE:\002,/,(10x,20(2x,i4),/))";
    static char fmt_7000[] = "(/,10x,\002CALCULATED POINT:\002,/,(t31,sp,e22.16))";
    static char fmt_4000[] = "(/,10x,a,i4)";
    static char fmt_5000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002THERE ARE NOT FEASIBLE POINTS.\002)";
    static char fmt_6000[] = "(/,80(\002-\002),/,10x,\002ITERATION:\002,i4,/,10x,\002OBJECTIVE FUNCTION :\002,f24.15)";
    static char fmt_8000[] = "(/,10x,\002SMALLEST LAGRANGE MULTIPLIER :\002,f19.14)";
    static char fmt_9000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002INDEFINITE CICLE ON A DEGENERATED POINT.\002)";
    static char fmt_10000[] = "(/,80(\002*\002),/,10x,a,/,10x,\002THE LIMIT FOR THE ITERATION       NUMBER HAS BEEN PASSED WITHOUT\002,/,10x,\002FINDING A FEASIBLE POINT.\002)";

     
    integer c_dim1, c_offset, q_dim1, q_offset, r_dim1, r_offset, i__1, i__2;
    doublereal d__1;

     
      int s_copy();
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt(), pow_dd();

     
    static integer iira, icol, nmid, irei;
    extern doublereal ddot_();
    static integer indx, iopt, icol1, icol2, icol3;
    extern doublereal dnrm0_(), dnrm2_();
    static doublereal test0;
    static integer i__, j, k, l;
    static doublereal s;
    extern   int anfm01_(), anfm02_(), anrs01_();
    static integer ireni, icont;
    extern   int auxo01_(), dcopy_(), dmmul_(), daxpy_();
    static integer i1, i2, m1, n1, n2, n3;
    static doublereal r1, s1, r2;
    static integer ia, ii, icicla, jj;
    extern doublereal dlamch_();
    static integer ni, nm, in, mr, iv;
    static doublereal xi;
    static integer ml;
    static doublereal gigant;
    static integer itemax;
    static doublereal cii;
    static char car[30];
    static integer mid, inf, ipc, nmd, nii;
    static doublereal csi;
    static integer mni;
    static doublereal eps, fun, wii, gig1;
    extern   int dadd_();

     
    static cilist io___2767 = { 0, 6, 0, fmt_1000, 0 };
    static cilist io___2768 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2774 = { 0, 0, 0, fmt_2000, 0 };
    static cilist io___2775 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2776 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2795 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2796 = { 0, 0, 0, fmt_3000, 0 };
    static cilist io___2798 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2802 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2803 = { 0, 0, 0, fmt_7000, 0 };
    static cilist io___2812 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2814 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___2815 = { 0, 0, 0, fmt_7000, 0 };
    static cilist io___2816 = { 0, 0, 0, fmt_4000, 0 };
    static cilist io___2817 = { 0, 0, 0, fmt_5000, 0 };
    static cilist io___2818 = { 0, 0, 0, fmt_6000, 0 };
    static cilist io___2819 = { 0, 0, 0, fmt_7000, 0 };
    static cilist io___2822 = { 0, 0, 0, fmt_5000, 0 };
    static cilist io___2823 = { 0, 0, 0, fmt_8000, 0 };
    static cilist io___2827 = { 0, 0, 0, fmt_9000, 0 };
    static cilist io___2838 = { 0, 0, 0, fmt_4000, 0 };
    static cilist io___2839 = { 0, 0, 0, fmt_10000, 0 };
     
    c_dim1 = *ic;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --ci;
    --cs;
    --b;
    --x;
    --w;
    --ipvt;
    --ire;

     
    s_copy(car, "END OF  OPTR01.", 30L, 15L);
    if (*mi < 0 || *md < 0 || *ira < 0 || *ira > 3 || *io < 1 || *n <= 1 || *
	    modo < 1 || *modo > 22 || *ic < *n && (*mi > 0 || *md > 0) || *iq 
	    < *n || *ir < *n) {
	if (*io <= 0) {
	    s_wsfe(&io___2767);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "INVALID NUMBER FOR THE WRITING CHANEL.", 38L);
	    e_wsfe();
	}
	if (*io > 0) {
	    io___2768.ciunit = *io;
	    s_wsfe(&io___2768);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "INVALID INTEGER VARIABLES.", 26L);
	    e_wsfe();
	}
	*ind = -5;
	return 0;
    }

 

    gigant = dlamch_("o", 1L);
    gig1 = sqrt(gigant);
    test0 = pow_dd(&gigant, &c_b7108);
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (*ira == 3) {
	    if (ci[i__] >= -gig1 && cs[i__] <= gig1 && ci[i__] > cs[i__]) {
		io___2774.ciunit = *io;
		s_wsfe(&io___2774);
		do_fio(&c__1, car, 30L);
		do_fio(&c__1, "CI(I).GT.CS(I) FOR I=", 21L);
		do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
		e_wsfe();
		*ind = -5;
		return 0;
	    }
	}
	if ((*modo == 2 || *modo == 4 || *modo == 12 || *modo == 14 || *modo 
		== 22) && *ira > 0) {
	    if (ire[i__] < -1 || ire[i__] > 1) {
		io___2775.ciunit = *io;
		s_wsfe(&io___2775);
		do_fio(&c__1, car, 30L);
		do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L);
		e_wsfe();
		*ind = -5;
		return 0;
	    }
	} else {
	    ire[i__] = 0;
	}
 
    }
    i__1 = *n + *md;
    for (i__ = *n + 1; i__ <= i__1; ++i__) {
	if (*modo == 2 || *modo == 4 || *modo == 12 || *modo == 14 || *modo ==
		 22) {
	    if (ire[i__] < 0 || ire[i__] > 1) {
		io___2776.ciunit = *io;
		s_wsfe(&io___2776);
		do_fio(&c__1, car, 30L);
		do_fio(&c__1, "INCORRECT VECTOR IRE.", 21L);
		e_wsfe();
		*ind = -5;
		return 0;
	    }
	} else {
	    ire[i__] = 0;
	}
 
    }

 

    n1 = *n + 1;
    n2 = n1 + *n;
    n3 = n2 + *n;
    nmd = n3 + *md;
    mni = *mi + 1;
    *ind = 0;
    icont = 0;
    icicla = 0;
    icol1 = 0;
    icol2 = 0;
    mid = *mi + *md;
    nmid = *n + mid;
    itemax = nmid << 2;
    s = dnrm0_(n, &x[1], &c__1);
    if (s == 0.) {
	indx = 0;
    } else {
	indx = 1;
    }

 

 
 
 

    iopt = 0;
    inf = 0;
    if (*modo > 20) {
	*modo += -20;
	inf = 1;
    } else if (*modo > 10) {
	*modo += -10;
    } else {
	iopt = 1;
    }

 
 

    if (*modo <= 2) {
	if (*mi == 0) {
	    *m = 0;
	}
	*mi1 = *mi;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[i__] = 0.;
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    w[i__] = 1.;
	    dcopy_(n, &w[1], &c__1, &q[i__ * q_dim1 + 1], &c__1);
	    w[i__] = 0.;
 
	}
    }

 

    if (*modo <= 2 && *mi >= 1) {
	*mi1 = 1;
	i2 = *mi;
	i__1 = *mi;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * c_dim1 + 
		    1], &w[1], n, mi1, ind, io);
	    if (*ind < 0) {
		ipvt[i2] = i__;
		*ind = 0;
		--i2;
	    } else {
		ipvt[*mi1] = i__;
		++(*mi1);
	    }
 
	}
	--(*mi1);
	if (*mi1 > 0) {
	    if (indx == 1) {
		i__1 = *mi1;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    l = ipvt[i__];
		    w[i__] = b[l] - ddot_(n, &c__[l * c_dim1 + 1], &c__1, &x[
			    1], &c__1);
 
		}
	    } else {
		i__1 = *mi1;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[i__] = b[ipvt[i__]];
		}
	    }
	    *ind = 1;
	    anrs01_(&r__[r_offset], ir, mi1, &w[1], &w[n1], ind, io);
	    *ind = 0;
	    dmmul_(&q[q_offset], iq, &w[n1], mi1, &w[n2], n, n, mi1, &c__1);
	    if (indx == 1) {
		dadd_(n, &w[n2], &c__1, &x[1], &c__1);
	    } else {
		dcopy_(n, &w[n2], &c__1, &x[1], &c__1);
	    }
	}

 
 

	if (*mi1 < *mi) {
	    i__1 = *mi;
	    for (i__ = *mi1 + 1; i__ <= i__1; ++i__) {
		l = ipvt[i__];
		if (*mi1 > 0) {
		    s = b[l] - ddot_(n, &x[1], &c__1, &c__[l * c_dim1 + 1], &
			    c__1);
		} else {
		    s = b[l];
		}
		if ((( s ) >= 0 ? ( s ) : -( s ))  > eps) {
		    *ind = -1;
		    if (*imp >= 11) {
			io___2795.ciunit = *io;
			s_wsfe(&io___2795);
			do_fio(&c__1, car, 30L);
			do_fio(&c__1, "THE SYSTEM OF EQUALITY CONSTRAINTS HAS NOT SOLUTION", 51L);
			e_wsfe();
		    }
		    return 0;
		}
 
	    }
	}
	*m = *mi1;
    }
    if (*imp >= 12 && *mi1 > 0) {
	io___2796.ciunit = *io;
	s_wsfe(&io___2796);
	i__1 = *mi1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *n + ipvt[i__];
	    do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
	}
	e_wsfe();
    }

 
 
 

    if (*modo == 2) {
	if (*ira > 0) {
	    i__ = 1;
	    if (i__ <= *n && *m < *n) {
L500:
		if (ire[i__] == 1) {
		    *ind = i__;
		}
		if (ire[i__] == -1) {
		    *ind = -i__;
		}
		if (*ind != 0) {
		    m1 = *m + 1;
		    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[1]
			    , n, &m1, ind, io);
		    if (*ind < 0) {
			*ind = 0;
			ire[i__] = 0;
		    } else {
			*m = m1;
			ipvt[*m] = ire[i__] * i__;
		    }
		}
		++i__;
		if (i__ <= *n && *m < *n) {
		    goto L500;
		}
	    }
	}
	if (*md > 0) {
	    i__ = 1;
	    if (i__ <= *md && *m < *n) {
L525:
		if (ire[*n + i__] == 1) {
		    m1 = *m + 1;
		    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[(*mi + 
			    i__) * c_dim1 + 1], &w[1], n, &m1, ind, io);
		    if (*ind < 0) {
			*ind = 0;
			ire[*n + i__] = 0;
		    } else {
			*m = m1;
			ipvt[*m] = *n + i__;
		    }
		}
		++i__;
		if (i__ <= *md && *m < *n) {
		    goto L525;
		}
	    }
	}
    }
    if (*modo == 2 && inf == 1) {
	if (*imp >= 11) {
	    io___2798.ciunit = *io;
	    s_wsfe(&io___2798);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "THE FACTORIZATION  QR  HAS BEEN OBTAINED.", 41L);
	    e_wsfe();
	}
	return 0;
    }

 

 

 

    mr = 0;
    if (inf == 0) {
	i__2 = *mi1;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    w[i__] = b[ipvt[i__]];
	}
	i__2 = *m;
	for (i__ = *mi1 + 1; i__ <= i__2; ++i__) {
	    l = ipvt[i__];
	    if (l < 0) {
		w[i__] = -ci[-l];
	    } else if (l <= *n) {
		w[i__] = cs[l];
	    } else {
		w[i__] = b[*mi + l - *n];
	    }
 
	}
	mr = *m;
	if (iopt == 1) {
	    if (*m > 0 && (*modo > 2 || *m > *mi1)) {
		*ind = 1;
		anrs01_(&r__[r_offset], ir, m, &w[1], &w[n1], ind, io);
		dmmul_(&q[q_offset], iq, &w[n1], m, &x[1], n, n, m, &c__1);
		*ind = 0;
	    }

 

	    *ind = 0;
	    auxo01_(&c__[mni * c_dim1 + 1], ic, &ci[1], &cs[1], &b[mni], &x[1]
		    , &w[n3], &ire[1], ira, n, md, ind, &fun, &iv);
	    if (iv == 0) {
		if (*imp >= 11) {
		    io___2802.ciunit = *io;
		    s_wsfe(&io___2802);
		    do_fio(&c__1, car, 30L);
		    do_fio(&c__1, "A FEASIBLE POINT HAS BEEN FOUND (1)", 35L);
		    e_wsfe();
		}
		if (*imp >= 13) {
		    io___2803.ciunit = *io;
		    s_wsfe(&io___2803);
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(
				doublereal));
		    }
		    e_wsfe();
		}
		return 0;
	    }
	}
    }

 

 
 

    if (*ira > 0) {
	i__ = 1;
	if (i__ <= *n && *m < *n) {
L550:
	    iira = 0;
	    if ((*ira == 1 || *ira == 3) && x[i__] <= ci[i__]) {
		iira = 1;
		*ind = -i__;
	    }
	    if (iira == 0 && *ira >= 2 && x[i__] >= cs[i__]) {
		iira = 1;
		*ind = i__;
	    }
	    if (iira > 0) {
		m1 = *m + 1;
		k = *ind;
		anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[n1], 
			n, &m1, ind, io);
		if (*ind < 0) {
		    *ind = 0;
		} else {
		    *m = m1;
		    ipvt[*m] = k;
		    if (k < 0) {
			ire[i__] = -1;
		    } else {
			ire[i__] = 1;
		    }
		}
	    }
	    ++i__;
	    if (i__ <= *n && *m < *n) {
		goto L550;
	    }
	}
    }
    if (*md > 0 && *m < *n) {
	i__ = *mi + 1;
	nii = *n - *mi;
	if (i__ <= mid && *m < *n) {
L575:
	    s = b[i__] - ddot_(n, &c__[i__ * c_dim1 + 1], &c__1, &x[1], &c__1)
		    ;
	    if (s <= eps) {
		m1 = *m + 1;
		anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * 
			c_dim1 + 1], &w[n1], n, &m1, ind, io);
		if (*ind < 0) {
		    *ind = 0;
		} else {
		    ni = nii + i__;
		    *m = m1;
		    ire[ni] = 1;
		    ipvt[*m] = ni;
		}
	    }
	    ++i__;
	    if (i__ <= mid && *m < *n) {
		goto L575;
	    }
	}
    }
    if (*ira > 0 && *m < *n && iopt == 0) {
	i__ = 1;
	if (i__ <= *n && *m < *n) {
L600:
	    j = ire[i__];
	    if (j == 0) {
		iira = 0;
		if (*ira == 1 && ci[i__] >= -gig1) {
		    *ind = -i__;
		    iira = 1;
		} else if (*ira == 2 && cs[i__] <= gig1) {
		    *ind = i__;
		    iira = 1;
		} else {
		    cii = ci[i__];
		    csi = cs[i__];
		    if (cii >= -gig1 || csi <= gig1) {
			xi = x[i__];
			iira = 1;
			if (xi - cii < csi - xi) {
			    *ind = -i__;
			} else {
			    *ind = i__;
			}
		    }
		}
		if (iira > 0) {
		    m1 = *m + 1;
		    k = *ind;
		    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[1], &w[
			    n1], n, &m1, ind, io);
		    if (*ind < 0) {
			*ind = 0;
		    } else {
			*m = m1;
			ipvt[*m] = k;
			if (k > 0) {
			    ire[i__] = 1;
			} else {
			    ire[i__] = -1;
			}
		    }
		}
	    }
	    ++i__;
	    if (i__ <= *n && *m < *n) {
		goto L600;
	    }
	}
    }
    i__ = *mi + 1;
    if (i__ <= mid && *m < *n && iopt == 0) {
L625:
	ni = nii + i__;
	j = ire[ni];
	if (j == 0) {
	    m1 = *m + 1;
	    anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &c__[i__ * c_dim1 + 
		    1], &w[n1], n, &m1, ind, io);
	    if (*ind < 0) {
		*ind = 0;
	    } else {
		*m = m1;
		ire[ni] = 1;
		ipvt[*m] = ni;
	    }
	}
	++i__;
	if (i__ <= mid && *m < *n && iopt == 0) {
	    goto L625;
	}
    }
    if (*modo == 1 && inf == 1) {
	if (*imp >= 11) {
	    io___2812.ciunit = *io;
	    s_wsfe(&io___2812);
	    do_fio(&c__1, car, 30L);
	    do_fio(&c__1, "THE FACTORIZATION  QR  HAS BEEN OBTAINED.", 41L);
	    e_wsfe();
	}
	return 0;
    }

 

    m1 = *m + 1;
    i__2 = *m;
    for (i__ = mr + 1; i__ <= i__2; ++i__) {
	l = ipvt[i__];
	if (l < 0) {
	    w[i__] = -ci[-l];
	} else if (l <= *n) {
	    w[i__] = cs[l];
	} else {
	    w[i__] = b[*mi + l - *n];
	}
 
    }
    if (iopt == 1 && mr < *m || iopt == 0) {
	*ind = 1;
	anrs01_(&r__[r_offset], ir, m, &w[1], &w[1], ind, io);
	dmmul_(&q[q_offset], iq, &w[1], m, &x[1], n, n, m, &c__1);
    }
    *ind = 0;
    nm = *n - *m;

 

    if (icont <= itemax) {

 
 

L650:
	if (icicla == 0) {
	    *ind = 1;
	    auxo01_(&c__[mni * c_dim1 + 1], ic, &ci[1], &cs[1], &b[mni], &x[1]
		    , &w[1], &ire[1], ira, n, md, ind, &fun, &iv);
	    *ind = 0;

 

 

	    if (iv == 0) {
		if (*imp >= 11) {
		    io___2814.ciunit = *io;
		    s_wsfe(&io___2814);
		    do_fio(&c__1, car, 30L);
		    do_fio(&c__1, "A FEASIBLE POINT HAS BEEN FOUND", 31L);
		    e_wsfe();
		}
		if (*imp >= 13) {
		    io___2815.ciunit = *io;
		    s_wsfe(&io___2815);
		    i__2 = *n;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(
				doublereal));
		    }
		    e_wsfe();
		}
		if (*imp >= 12) {
		    io___2816.ciunit = *io;
		    s_wsfe(&io___2816);
		    do_fio(&c__1, "NUMBER OF ITERATIONS:", 21L);
		    do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer));
		    e_wsfe();
		}
		return 0;
	    } else if (iv == 1 && *mi1 == *m) {
		*ind = -2;
		if (*imp >= 11) {
		    io___2817.ciunit = *io;
		    s_wsfe(&io___2817);
		    do_fio(&c__1, car, 30L);
		    e_wsfe();
		}
		return 0;
	    } else {
		if (*imp >= 13) {
		    io___2818.ciunit = *io;
		    s_wsfe(&io___2818);
		    do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&fun, (ftnlen)sizeof(doublereal));
		    e_wsfe();
		    if (*imp >= 14) {
			io___2819.ciunit = *io;
			s_wsfe(&io___2819);
			i__2 = *n;
			for (i__ = 1; i__ <= i__2; ++i__) {
			    do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(
				    doublereal));
			}
			e_wsfe();
		    }
		}
	    }
	}
	++icont;
	if (*m < *n) {
	    j = n2;
	    i__2 = *n;
	    for (i__ = m1; i__ <= i__2; ++i__) {
		w[j] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &w[1], &c__1);
		++j;
 
	    }
	    i__2 = *n - *m;
	    s = dnrm2_(&i__2, &w[n2], &c__1);
	    s = (( s ) >= 0 ? ( s ) : -( s )) ;
	} else {
	    s = 0.;
	}
	if (s < eps) {

 

	    i__2 = *m;
	    for (i__ = 1; i__ <= i__2; ++i__) {
 
		w[*n + i__] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &w[1], &
			c__1);
	    }
	    *ind = 2;
	    anrs01_(&r__[r_offset], ir, m, &w[n1], &w[n2], ind, io);

 

 

	    *ind = 0;
	    icol = *mi1 + 1;
	    s1 = w[n2 + *mi1];
	    i__2 = *m - 1;
	    for (i__ = *mi1 + 1; i__ <= i__2; ++i__) {
		j = n2 + i__;
		if (w[j] < s1) {
		    s1 = w[j];
		    icol = i__ + 1;
		}
 
	    }
	    if (s1 > -eps) {
		if (*imp >= 11) {
		    io___2822.ciunit = *io;
		    s_wsfe(&io___2822);
		    do_fio(&c__1, car, 30L);
		    e_wsfe();
		    io___2823.ciunit = *io;
		    s_wsfe(&io___2823);
		    do_fio(&c__1, (char *)&s1, (ftnlen)sizeof(doublereal));
		    e_wsfe();
		}
		*ind = -2;
		return 0;
	    }

 

	    anfm02_(&q[q_offset], iq, &r__[r_offset], ir, n, m, &icol, io);

 

	    s1 = ddot_(n, &q[*n * q_dim1 + 1], &c__1, &w[1], &c__1);
	    dcopy_(n, &q[*n * q_dim1 + 1], &c__1, &w[n1], &c__1);
	    if (s1 < 0.) {
		i__2 = n2 - 1;
		for (i__ = n1; i__ <= i__2; ++i__) {
 
		    w[i__] = -w[i__];
		}
	    } else {
		s1 = -s1;
	    }
	} else {
	    i__2 = *n - *m;
	    i__1 = *n - *m;
	    dmmul_(&q[m1 * q_dim1 + 1], iq, &w[n2], &i__2, &w[n1], n, n, &
		    i__1, &c__1);
	    s1 = -ddot_(n, &w[1], &c__1, &w[n1], &c__1);
	    icol = n1;
	}

 

	k = 0;
	if (*ira > 0) {
	    i__ = 0;
	    if (i__ < *n && k == 0) {
L675:
		++i__;
		ii = *n + i__;
		if (*ira > 1) {
		    if (cs[i__] <= gig1 && ire[i__] == 0 && w[ii] > eps && x[
			    i__] >= cs[i__] - eps) {
			k = 1;
			icol3 = i__;
		    }
		}
		if (k == 0 && *ira != 2) {
		    if (ci[i__] >= -gig1 && ire[i__] == 0 && w[ii] < -eps && 
			    x[i__] <= ci[i__] + eps) {
			k = 1;
			icol3 = -i__;
		    }
		}
		if (i__ < *n && k == 0) {
		    goto L675;
		}
	    }
	}
	i__ = 0;
	if (i__ < *md && k == 0) {
L700:
	    ii = nmd + i__;
	    in = n3 + i__;
	    ++i__;
	    ni = *n + i__;
	    if (ire[ni] != 1) {
		w[ii] = ddot_(n, &c__[(*mi + i__) * c_dim1 + 1], &c__1, &w[n1]
			, &c__1);
		if (ire[ni] == 0 && w[in] >= -eps && w[ii] > eps) {
		    k = 1;
		    icol3 = ni;
		}
	    }
	    if (i__ < *md && k == 0) {
		goto L700;
	    }
	}

 

 

	if (k == 1) {
	    ++icicla;
	    if (icol < n1) {
		if (icicla > *m || icol3 == icol1 && icol == *m) {
		    if (*imp >= 11) {
			io___2827.ciunit = *io;
			s_wsfe(&io___2827);
			do_fio(&c__1, car, 30L);
			e_wsfe();
		    }
		    *ind = -3;
		    return 0;
		}
		icol1 = icol2;
		icol2 = icol3;
		i__ = ipvt[icol];
		if (i__ > *n) {
		    w[n2 + i__] = ddot_(n, &c__[(i__ - *n + *mi) * c_dim1 + 1]
			    , &c__1, &x[1], &c__1) - b[i__ - *n + *mi];
		}
	    }
	} else if (icicla > 0) {
	    icicla = 0;
	    icol1 = 0;
	    icol2 = 0;
	}

 

 

	k = 0;
	if (*ira > 0) {
	    i__ = 0;
	    if (i__ < *n && icicla == 0) {
L725:
		i1 = i__ + 1;
		j = 0;
		ii = n1 + i__;
		wii = w[ii];
		irei = ire[i1];
		if (*ira > 1) {
		    if (cs[i1] <= gig1 && (irei == 0 && wii > eps || irei == 
			    2 && wii < -eps)) {
			w[n2 + k] = (cs[i1] - x[i1]) / wii;
			++k;
			ipvt[*m + k] = i1;
			j = 1;
		    }
		}
		if (j == 0 && *ira != 2) {
		    if (ci[i1] >= -gig1 && (irei == 0 && wii < -eps || irei ==
			     -2 && wii > eps)) {
			w[n2 + k] = (ci[i1] - x[i1]) / wii;
			++k;
			ipvt[*m + k] = -i1;
		    }
		}
		i__ = i1;
		if (i__ < *n && icicla == 0) {
		    goto L725;
		}
	    }
	}
	if (icol < n1) {
	    ipc = ipvt[icol];
	    ia = (( ipc ) >= 0 ? ( ipc ) : -( ipc )) ;
	    if (icicla == 0 && ia <= *n && *ira == 3) {
		cii = ci[ia];
		csi = cs[ia];
		if (cii >= -gig1 && csi <= gig1) {
		    ++k;
		    if (ipc < 0) {
			w[n2 + k - 1] = (csi - x[ia]) / w[*n + ia];
			ipvt[*m + k] = ia;
		    } else {
			w[n2 + k - 1] = (cii - x[ia]) / w[*n + ia];
			ipvt[*m + k] = -ia;
		    }
		}
	    }
	}
	i__ = 0;
	if (i__ < *md && icicla == 0) {
L750:
	    i1 = i__ + 1;
	    ii = nmd + i__;
	    ni = *n + i1;
	    ireni = ire[ni];
	    wii = w[ii];
	    if (ireni == 0 && wii > eps || ireni == 2 && wii < -eps) {
		w[n2 + k] = -w[n3 + i__] / wii;
		++k;
		ipvt[*m + k] = ni;
	    }
	    i__ = i1;
	    if (i__ < *md && icicla == 0) {
		goto L750;
	    }
	}

 

	r2 = 0.;
	if (icicla == 0 && s1 < -eps) {
L775:
	    l = 0;
	    r1 = r2;
	    r2 = gigant;
	    i__2 = k;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		ii = n2 + i__ - 1;
		wii = w[ii];
		if (wii <= r2 && wii > r1) {
		    if (wii < r2) {
			l = 0;
		    }
		    r2 = wii;
		    w[ii] = w[n2 + l];
		    w[n2 + l] = r2;
		    ni = *m + i__;
		    ++l;
		    j = ipvt[ni];
		    ml = *m + l;
		    ipvt[ni] = ipvt[ml];
		    ipvt[ml] = j;
		}
 
	    }

 

 

	    icol3 = ipvt[m1];
	    i__2 = l;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		j = ipvt[*m + i__];
		if (j < 0) {
		    j = -j;
		    jj = *n + j;
		    if (ire[j] == -2) {
			s1 += w[jj];
			if (*ira == 3) {
			    if (ci[j] >= -gig1 && cs[j] <= gig1) {
				ire[j] = 0;
				ipvt[*m + i__] = j;
				w[n2 + i__ - 1] = (cs[j] - x[j]) / w[*n + j];
			    }
			}
		    } else {
			s1 -= w[jj];
		    }
		} else if (j < n1) {
		    jj = *n + j;
		    if (ire[j] == 2) {
			s1 -= w[jj];
			if (*ira == 3) {
			    if (ci[j] >= -gig1 && cs[i__] <= gig1) {
				ire[j] = 0;
				ipvt[*m + i__] = -j;
				w[n2 + i__ - 1] = (ci[j] - x[j]) / w[*n + j];
			    }
			}
		    } else {
			s1 += w[jj];
		    }
		} else if (j > *n) {
		    jj = nmd + j - n1;
		    if (ire[j] == 2) {
			s1 -= w[jj];
		    }
		    if (ire[j] == 0) {
			s1 += w[jj];
		    }
		}
 
	    }
	    if (icicla == 0 && s1 < -eps) {
		goto L775;
	    }
	}

 

	if (icicla == 0) {
	    ipvt[m1] = icol3;
	    daxpy_(n, &r2, &w[n1], &c__1, &x[1], &c__1);
	}

 

 
 

	if (icol3 < 0) {
	    ire[-icol3] = -1;
	} else {
	    ire[icol3] = 1;
	}
	if (icol < n1) {
	    ire[ia] = 0;
	    i__2 = *m - 1;
	    for (j = icol; j <= i__2; ++j) {
 
		ipvt[j] = ipvt[j + 1];
	    }
	    ipvt[*m] = icol3;
	} else {
	    icicla = 0;
	    *m = m1;
	    ++m1;
	}
	if (icol3 <= *n) {
	    *ind = icol3;
	} else {
	    dcopy_(n, &c__[(*mi + icol3 - *n) * c_dim1 + 1], &c__1, &w[n1], &
		    c__1);
	}
	anfm01_(&q[q_offset], iq, &r__[r_offset], ir, &w[n1], &w[n2], n, m, 
		ind, io);
	*ind = 0;
	if (icicla != 0 && *imp >= 13) {
	    io___2838.ciunit = *io;
	    s_wsfe(&io___2838);
	    do_fio(&c__1, "A DEGENERATED POINT HAS BEEN FOUND IN THE ITERATION:", 52L);
	    do_fio(&c__1, (char *)&icont, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	if (icont <= itemax) {
	    goto L650;
	}
    }
    if (*imp >= 11) {
	io___2839.ciunit = *io;
	s_wsfe(&io___2839);
	do_fio(&c__1, car, 30L);
	e_wsfe();
    }
    *ind = -4;
}  

  int optr03_(a, ia, c__, ic, q, iq, r__, ir, p, b, d__, ci, 
	cs, x, w, iw, ire, ipvt, jpvt, alfa, ira, n, m, mi, mi1, md, mif, mdf,
	 modo, ind, imp, io, iter)
doublereal *a;
integer *ia;
doublereal *c__;
integer *ic;
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *p, *b, *d__, *ci, *cs, *x, *w;
integer *iw, *ire, *ipvt, *jpvt;
doublereal *alfa;
integer *ira, *n, *m, *mi, *mi1, *md, *mif, *mdf, *modo, *ind, *imp, *io, *
	iter;
{
     
    integer c_dim1, c_offset, a_dim1, a_offset, q_dim1, q_offset, r_dim1, 
	    r_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    double pow_dd(), sqrt();

     
    static integer iadd;
    extern   int ddif_();
    static integer midf, ides, icol, nmdi, indm;
    extern doublereal ddot_();
    static integer info;
    extern   int tol03_();
    static integer iver, inul, icol1, icol2, icol3;
    extern   int aux003_();
    extern doublereal dnrm0_(), dnrm2_();
    static integer i__, j, k, l;
    static doublereal s;
    extern   int anfm01_(), anfm03_(), dscal_(), anfm02_(), 
	    anfm06_(), anfm04_(), dimp03_(), anfm05_();
    static integer iicol;
    extern   int desr03_(), anrs01_(), pasr03_();
    static integer icont;
    extern   int auxo01_(), dmmul_(), dcopy_();
    extern doublereal opvf03_();
    extern   int optr01_(), nvkt03_(), daxpy_();
    static integer i1, j1, m0, m1, n1, n2, n3, m2;
    static doublereal s1, s2, s3;
    static integer id, n10, nd, ii, icicla, il;
    extern doublereal dlamch_();
    static integer ni, ip, nm, iv, iibeta;
    static doublereal ro;
    extern integer idamax_();
    static integer jj, in;
    static doublereal sj, sk;
    static integer nf;
    static doublereal gigant, sw, epsmch, dnorma;
    static integer itemax, minimo, nd1, nm1;
    static doublereal xi1;
    static integer iad, icd;
    static doublereal cii;
    static integer mid, nmd;
    static doublereal csi;
    static integer nmf, idw;
    static doublereal eps, fun, gig1;
    static integer ind1;
    static doublereal eps0;
    extern   int dadd_();
     
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    c_dim1 = *ic;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    --p;
    --b;
    --d__;
    --ci;
    --cs;
    --x;
    --w;
    --ire;
    --ipvt;
    --jpvt;

     
    if (*ic < *n && (*mi > 0 || *md > 0) || *n <= 1 || *ir < *n || (*mif > 0 
	    || *mdf > 0) && *ia < *n || *iq < *n || *modo < -1 || *modo > 6 ||
	     *mi < 0 || *md < 0 || *mif < 0 || *mdf < 0 || *ira < 0 || *ira > 
	    3 || *io < 1) {
	*ind = -4;
	dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &c__0, &
		c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter);
	return 0;
    }

 

    epsmch = dlamch_("p", 1L);
    eps = pow_dd(&epsmch, &c_b5779);
    eps0 = pow_dd(&epsmch, &c_b5732);
    gigant = dlamch_("o", 1L);
    gig1 = sqrt(gigant);

 

    if (*ira > 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (*ira == 3) {
		if (ci[i__] >= -gig1 && cs[i__] <= gig1 && ci[i__] > cs[i__]) 
			{
		    if (*imp >= 7) {
			dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &i__, &
				c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &
				c__0, &c__0, &c_n24, imp, io, iter);
		    }
		    *ind = -4;
		    return 0;
		}
	    }
	    if (*modo == 3 || *modo == 5 || *modo <= 0) {
		if (ire[i__] < -1 || ire[i__] > 1) {
		    if (*imp >= 7) {
			dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &
				c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &
				c__0, &c__0, &c_n34, imp, io, iter);
		    }
		    *ind = -4;
		    return 0;
		}
	    }
 
	}
    }
    if (*modo == 3 || *modo == 5 || *modo <= 0) {
	i__1 = *n + *md + *mif + *mdf;
	for (i__ = *n + 1; i__ <= i__1; ++i__) {
	    if ((ire[i__] < 0 || ire[i__] > 1) && i__ <= *n + *md || (ire[i__]
		     < -2 || ire[i__] > 2) && i__ > *n + *md) {
		if (*imp >= 7) {
		    dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0,
			     &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, 
			    &c_n34, imp, io, iter);
		}
		*ind = -4;
		return 0;
	    }
 
	}
    }

 

    if (*modo > 3) {
	iver = 1;
	if (*modo == 6) {
	    *modo = 1;
	} else {
	    *modo += -2;
	}
    } else {
	iver = -1;
    }
    n1 = *n + 1;
    n2 = n1 + *n;
    n3 = n2 + *n;
    n10 = *iq * 10;
    if (*modo != 3 || *modo != 0) {
	*mi1 = *mi;
    }
    mid = *mi + *md;
    midf = *mif + *mdf;
    nmd = *n + *md;
    nmdi = nmd + *mif;
    nd1 = nmd + 1;
    nd = nmd + midf + 1;
    icd = nd + *n;
    iad = icd + *md;
    idw = iad + midf;
    *iter = 0;
    id = 0;
    *ind = 0;
    icicla = 0;
    il = 0;
    icol = 0;
    icol1 = 0;
    icol2 = 0;
    iicol = 0;
    info = 0;
    itemax = *n + mid + midf << 2;
    icont = 0;
    if (*ira == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    ire[i__] = 0;
	}
    }

 
 
 

    if (*modo == -1) {
	if (*mi == 0) {
	    *m = 0;
	}
	if (mid == 0) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		i__2 = *n;
		for (j = 1; j <= i__2; ++j) {
		    if (i__ == j) {
			q[i__ + j * q_dim1] = 1.;
		    } else {
			q[i__ + j * q_dim1] = 0.;
		    }
 
		}
 
	    }
	}
	if (mid == 0 && *ira > 0) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		if (ire[i__] == 1) {
		    *ind = i__;
		}
		if (ire[i__] == -1) {
		    *ind = -i__;
		}
		if (*ind != 0) {
		    ++(*m);
		    anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &w[
			    1], &w[1], n, m, ind, io);
		    ipvt[*m] = ire[i__] * i__;
		}
 
	    }
	} else if (mid > 0) {
	    *modo = 22;
	    optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) 
		    + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[1], &ipvt[1],
		     &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo);
	    *modo = -1;
	}
	if (midf > 0) {
	    i__ = 1;
	    if (i__ <= midf && *m < *n) {
L1000:
		ni = nmd + i__;
		if (ire[ni] == 1) {
		    m1 = *m + 1;
		    *ind = 0;
		    anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &a[
			    i__ * a_dim1 + 1], &w[1], n, &m1, ind, io);
		    if (*ind < 0) {
			ire[ni] = 0;
		    } else {
			*m = m1;
			ipvt[*m] = ni;
		    }
		}
		++i__;
		if (i__ <= midf && *m < *n) {
		    goto L1000;
		}
	    }
	}
    }

 

 

 

    if (*modo <= 0) {
	i1 = idamax_(n, &x[1], &c__1);
	s1 = x[i1];
	if (s1 == 0.) {
	    i__1 = *mi1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i__] = d__[ipvt[i__]];
	    }
	    i__1 = *m;
	    for (i__ = *mi1 + 1; i__ <= i__1; ++i__) {
		l = ipvt[i__];
		if (l < 0) {
		    w[i__] = -ci[-l];
		} else if (l <= *n) {
		    w[i__] = cs[l];
		} else if (l <= nmd) {
		    w[i__] = d__[*mi + l - *n];
		} else {
		    w[i__] = b[l - nmd];
		}
 
	    }
	} else {
	    i__1 = *mi1;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		l = ipvt[i__];
		w[i__] = d__[l] - ddot_(n, &c__[l * c_dim1 + 1], &c__1, &x[1],
			 &c__1);
 
	    }
	    i__1 = *m;
	    for (i__ = *mi1 + 1; i__ <= i__1; ++i__) {
		l = ipvt[i__];
		if (l < 0) {
		    w[i__] = -ci[-l] + x[-l];
		} else if (l <= *n) {
		    w[i__] = cs[l] - x[l];
		} else if (l <= nmd) {
		    ni = *mi + l - *n;
		    w[i__] = d__[ni] - ddot_(n, &c__[ni * c_dim1 + 1], &c__1, 
			    &x[1], &c__1);
		} else {
		    ni = l - nmd;
		    w[i__] = b[ni] - ddot_(n, &a[ni * a_dim1 + 1], &c__1, &x[
			    1], &c__1);
		}
 
	    }
	}
	*ind = 1;
	anrs01_(&r__[(r_dim1 << 1) + 1], ir, m, &w[1], &w[n1], ind, io);
	*ind = 0;
	dmmul_(&q[q_offset], iq, &w[n1], m, &w[1], n, n, m, &c__1);
	dadd_(n, &x[1], &c__1, &w[1], &c__1);

 

 

 

	iv = 0;
	if (mid > 0 || *ira > 0) {
	    i1 = *mi + 1;
	    auxo01_(&c__[i1 * c_dim1 + 1], ic, &ci[1], &cs[1], &d__[i1], &w[1]
		    , &w[n1], &ire[1], ira, n, md, ind, &fun, &iv);
	}
	if (iv == 0) {
	    dcopy_(n, &w[1], &c__1, &x[1], &c__1);
	} else {
	    *modo = 2;
	}
    }

 
 
 

    if (mid == 0 && (*modo == 2 || *modo == 1 && *ira == 0)) {
	*m = 0;
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *n;
	    for (j = 1; j <= i__2; ++j) {
		if (i__ == j) {
		    q[i__ + j * q_dim1] = 1.;
		} else {
		    q[i__ + j * q_dim1] = 0.;
		}
 
	    }
 
	}
    }

 

 

 

    if (*modo == 1) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    x[i__] = 0.;
	}
	if (mid > 0 || *ira > 0) {
	    if (iver == 1) {
		*modo = 11;
	    }
	    optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) 
		    + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[1], &ipvt[1],
		     &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo);
	    if (iver == 1) {
		*modo = 1;
	    }
	    if (*ind < 0) {
		*ind += -10;
		if (*imp >= 7 && *imp <= 10) {
		    dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0,
			     &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, 
			    ind, imp, io, iter);
		}
		return 0;
	    }
	    dcopy_(md, &w[n3], &c__1, &w[n1], &c__1);
	}
    }

 
 

    if (*modo == 2) {
	*m = 0;
	if (*ira >= 1) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		ire[i__] = 0;
		if (*ira != 2) {
		    if (ci[i__] >= -gig1) {
			if (x[i__] < ci[i__] + eps) {
			    x[i__] = ci[i__];
			    ire[i__] = -1;
			    if (mid == 0) {
				++(*m);
				ip = -i__;
				anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) 
					+ 1], ir, &x[1], &w[1], n, m, &ip, io)
					;
				ipvt[*m] = -i__;
			    }
			}
		    }
		}
		if (*ira >= 2) {
		    if (cs[i__] <= gig1 && ire[i__] == 0) {
			if (x[i__] > cs[i__] - eps) {
			    x[i__] = cs[i__];
			    ire[i__] = 1;
			    if (mid == 0) {
				++(*m);
				ip = i__;
				anfm01_(&q[q_offset], iq, &r__[(r_dim1 << 1) 
					+ 1], ir, &x[1], &w[1], n, m, &ip, io)
					;
				ipvt[*m] = i__;
			    }
			}
		    }
		}
 
	    }
	}
	i__1 = *md;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ii = *mi + i__;
	    s = ddot_(n, &c__[ii * c_dim1 + 1], &c__1, &x[1], &c__1) - d__[ii]
		    ;
	    ni = *n + i__;
	    if (s > -eps) {
		ire[ni] = 1;
	    } else {
		ire[ni] = 0;
	    }
	    w[ni] = s;
 
	}
	if (mid > 0) {
	    *modo = 22;
	    optr01_(&c__[c_offset], ic, &q[q_offset], iq, &r__[(r_dim1 << 1) 
		    + 1], ir, &ci[1], &cs[1], &d__[1], &x[1], &w[nd1], &ipvt[
		    1], &ire[1], ira, n, m, mi, mi1, md, ind, imp, io, modo);
	    *modo = 2;
	}
    }
    iv = 0;
    if (iver == 1) {
	iv = *m;
	iver = *m;
    }

 

 

    if (*modo == 3) {
	i__1 = *md;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ii = *mi + i__;
	    ni = *n + i__;
	    w[ni] = 0.;
	    if (ire[ni] == 0) {
		w[ni] = ddot_(n, &c__[ii * c_dim1 + 1], &c__1, &x[1], &c__1) 
			- d__[ii];
	    }
 
	}
	i__1 = midf;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ii = (i__2 = ire[nmd + i__], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) );
	    if (i__ <= *mif && ii == 2 || ii != 1) {
		w[nmd + i__] = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &
			c__1) - b[i__];
	    } else {
		w[nmd + i__] = 0.;
	    }
 
	}
    } else {
	i__1 = midf;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    w[nmd + i__] = 0.;
	}
	*ind = 0;
	if (*modo > 0) {
	    i__1 = nmd + midf;
	    for (i__ = nd1; i__ <= i__1; ++i__) {
 
		ire[i__] = 0;
	    }
	}
	aux003_(&a[a_offset], ia, &x[1], &b[1], &q[q_offset], iq, &r__[(
		r_dim1 << 1) + 1], ir, &w[nd1], &ire[nd1], &ipvt[1], &nmd, 
		mif, mdf, &midf, n, m, ind, io);
    }
    if (*m == *n) {
	minimo = 1;
	id = 2;
	nm = 0;
    } else {
	minimo = 0;
    }

 

    if (minimo == 0 && *modo != -2) {
	m1 = *m + 1;
	nm = *n - *m;
	*ind = 0;
	i__1 = iver - iv;
	anfm03_(&r__[r_offset], ir, &r__[(m1 + 1) * r_dim1 + 1], ir, &q[m1 * 
		q_dim1 + 1], iq, &w[1], &jpvt[1], n, &nm, ind, &i__1, io);
	if (*ind <= -n10) {
	    *ind += n10;
	    iibeta = 1;
	} else {
	    iibeta = 0;
	}
	if (*ind == *n && iver == iv) {
	    *ind = -1;
	    if (*imp >= 7) {
		dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0, &
			c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, 
			imp, io, iter);
	    }
	    return 0;
	}
    } else if (minimo == 0) {
	nm = *n - *m;
    }

 

    if (*iter <= itemax) {
L2000:
	iadd = 0;
	ind1 = 0;
	il = 0;
	if (iicol == 1) {
	    id = 2;
	}

 

	if (icicla == 0) {
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		i1 = i__ + 1;
		s = ddot_(&i__, &r__[i__ + r_dim1], ir, &x[1], &c__1);
		if (i__ < *n) {
		    i__2 = *n - i__;
		    w[i__] = s + ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, 
			    &x[i1], &c__1);
		}
 
	    }
	    w[*n] = s;
	    dadd_(n, &p[1], &c__1, &w[1], &c__1);
	    if (*alfa != 1.) {
		dscal_(n, alfa, &w[1], &c__1);
	    }
	    i__1 = *mif;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		ni = nmd + i__;
		if (ire[ni] == 2) {
		    dadd_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1);
		} else if (ire[ni] == -2) {
		    ddif_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1);
		}
 
	    }
	    i__1 = midf;
	    for (i__ = *mif + 1; i__ <= i__1; ++i__) {
 
		if (ire[i__ + nmd] == 2) {
		    dadd_(n, &a[i__ * a_dim1 + 1], &c__1, &w[1], &c__1);
		}
	    }
	}

 

 

 

	s1 = gigant;
	s2 = 0.;
	inul = 0;
	if (id >= 2) {
	    i1 = icd - 1;
	    i__1 = nm;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		w[i1 + i__] = ddot_(n, &q[(n1 - i__) * q_dim1 + 1], &c__1, &w[
			1], &c__1);
	    }
	    if (minimo == 0) {
		s2 = dnrm2_(&nm, &w[icd], &c__1) / (dnrm0_(n, &x[1], &c__1) + 
			1);
	    }
	    if (s2 >= eps0) {
		info = 10;
		++icont;
	    } else if (icont > 0) {
		icont = 0;
	    }
	    if ((*m > *mi1 || (*imp >= 8 || *iw == 1) && *m > 0) && (icont == 
		    0 || icont == 3)) {
		i__1 = *m;
		for (i__ = 1; i__ <= i__1; ++i__) {
 
		    w[nd + i__ - 1] = -ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &
			    w[1], &c__1);
		}
		anrs01_(&r__[(r_dim1 << 1) + 1], ir, m, &w[nd], &w[nd], &c__2,
			 io);
		if (*m > *mi1) {

 

 

		    indm = 1;
		    if (indm == 1) {
L3000:
			icol = 0;
			j = nd - 1 + *mi1;
			i__1 = *m;
			for (i__ = *mi1 + 1; i__ <= i__1; ++i__) {
			    ++j;
			    k = ipvt[i__];
			    if (k <= nmd) {
				s = w[j];
			    } else if (k > nmd && k <= nmdi) {
				s = 1. - (d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
			    } else {
				sw = w[j];
 
				d__1 = sw, d__2 = 1. - sw;
				s = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
			    }
			    if (s < s1) {
				s1 = s;
				icol = i__;
			    }
 
			}
			if (icol != 0) {
			    if (ipvt[icol] > nmd) {
				inul = 1;
			    }
			}
			if (s1 < -eps || s1 <= eps && inul == 0) {
			    if (inul == 0 && (( s1 ) >= 0 ? ( s1 ) : -( s1 ))  <= eps) {
				dcopy_(m, &w[nd], &c__1, &w[icd], &c__1);
			    }
			    if (icont > 0) {
				icont = 0;
			    }

 

 

 

 

			    if (*m > 1) {
				anfm02_(&q[q_offset], iq, &r__[(r_dim1 << 1) 
					+ 1], ir, n, m, &icol, io);
			    }
			    m1 = *m - 1;
			    il = ipvt[icol];
			    if (il > *n) {
				w[il] = 0.;
			    }
			    s = w[nd + icol - 1];
			    ire[(( il ) >= 0 ? ( il ) : -( il )) ] = 0;
			    i__1 = m1;
			    for (j = icol; j <= i__1; ++j) {
 
				ipvt[j] = ipvt[j + 1];
			    }
			    if (minimo == 1) {
				*ind = 0;
				nm = 0;
			    }
			    anfm06_(&q[*m * q_dim1 + 1], iq, &r__[r_offset], 
				    ir, &w[nd], &jpvt[1], n, &nm, ind, io);
			    info = 1;
			    *m = m1;
			    if (iver != -1 && il <= nmd) {
				--iver;
			    } else if (iver == iv && *ind < 0) {
				*ind = -1;
				if (*imp >= 7) {
				    dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &
					    s, &c__0, &c__0, &c__0, &c__0, &
					    c__0, &c__0, &c__0, &c__0, &c__0, 
					    ind, imp, io, iter);
				}
				return 0;
			    }
			}
			if (*ind < 0 || *ind > nm || (( s1 ) >= 0 ? ( s1 ) : -( s1 ))  > eps) {
			    indm = 0;
			} else {
			    s1 = gigant;
			    i__1 = icol - 1;
			    dcopy_(&i__1, &w[icd], &c__1, &w[nd], &c__1);
			    j1 = nd + icol - 1;
			    i__1 = icd + *m;
			    for (j = icd + icol; j <= i__1; ++j) {
				w[j1] = w[j];
				++j1;
 
			    }
			}
			if (indm == 1) {
			    goto L3000;
			}
		    }
		}
	    }
	}

 


	if (id >= 2 && (s1 > eps || s1 >= -eps && inul == 1) && (s2 < eps0 || 
		icont >= 3)) {
	    tol03_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &c__[
		    c_offset], ic, &d__[1], &a[a_offset], ia, &b[1], &ci[1], &
		    cs[1], &x[1], &w[nd + *m], &ipvt[1], n, m, mi, mi1, &nmd, 
		    io);
	    *ind = 0;
	    if (*iw != 0) {
		*iw = nd + *m;
		w[*iw] = opvf03_(&r__[r_offset], ir, &a[a_offset], ia, &p[1], 
			&b[1], &x[1], &w[1], alfa, &nd, n, mif, mdf);
	    }
	    if (*imp >= 8) {
		if (*iw != 0) {
		    s = w[*iw];
		}
		nvkt03_(&a[a_offset], ia, &c__[c_offset], ic, &w[1], &w[nd], &
			w[nd + *m], &ipvt[1], &dnorma, n, m, mi1, mi, &nmd, &
			nd);
		if (*iw != 0) {
		    w[*iw] = s;
		    w[*iw + 1] = dnorma;
		}
	    }
	    if (*imp >= 7) {
		dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &dnorma, n, m, &nd, 
			iw, &c__0, &c__0, &c__0, mi, mi1, ind, imp, io, iter);
	    }
	    return 0;
	}

 

 

	if (il > nmd) {
	    k = il - nmd;
	    if (s > 0.) {
		dadd_(n, &a[k * a_dim1 + 1], &c__1, &w[1], &c__1);
	    } else if (s < 0. && il <= nmdi) {
		ddif_(n, &a[k * a_dim1 + 1], &c__1, &w[1], &c__1);
	    }
	}
 

	m1 = *m + 1;
	m2 = m1 + 1;
	desr03_(&q[m1 * q_dim1 + 1], iq, &r__[m2 * r_dim1 + 1], ir, &w[1], &w[
		icd], &w[nd], alfa, &jpvt[1], &nm, n, ind, &info, &id, &ro, 
		io);
	if (*imp >= 9) {
	    if (id == 1) {
		ides = 1;
	    } else if (*ind > 0 && *ind <= nm) {
		ides = 0;
	    } else {
		ides = -1;
	    }
	}

 

	k = 0;
	if (iver == -1 || iver != iv) {
	    if (*ira > 0) {
		i__ = 0;
		if (i__ < *n && k == 0) {
L4000:
		    i1 = i__ + 1;
		    ii = i__ + nd;
		    xi1 = x[i1];
		    if (*ira > 1) {
			csi = cs[i1];
			if (csi <= gig1 && ire[i1] == 0 && w[ii] > eps && xi1 
				>= csi - eps) {
			    s2 = dnrm2_(&nm, &q[i1 + m1 * q_dim1], iq);
			    if (s2 >= epsmch) {
				k = 1;
				ipvt[m1] = i1;
			    } else {
				w[ii] = 0.;
			    }
			}
		    }
		    if (k == 0 && *ira != 2) {
			cii = ci[i1];
			if (cii >= -gig1 && ire[i1] == 0 && w[ii] < -eps && 
				xi1 <= cii + eps) {
			    s2 = dnrm2_(&nm, &q[i1 + m1 * q_dim1], iq);
			    if (s2 >= epsmch) {
				k = 1;
				ipvt[m1] = -i1;
			    } else {
				w[ii] = 0.;
			    }
			}
		    }
		    i__ = i1;
		    if (i__ < *n && k == 0) {
			goto L4000;
		    }
		}
	    }
	    i__ = 0;
	    if (i__ < *md && k == 0) {
L5000:
		ii = icd + i__;
		++i__;
		ni = *n + i__;
		if (ire[ni] != 1) {
		    w[ii] = ddot_(n, &c__[(*mi + i__) * c_dim1 + 1], &c__1, &
			    w[nd], &c__1);
		    if (w[ni] >= -eps && w[ii] > eps) {
			jj = idw;
			i__1 = *n;
			for (j = m1; j <= i__1; ++j) {
			    w[jj] = ddot_(n, &q[j * q_dim1 + 1], &c__1, &c__[(
				    *mi + i__) * c_dim1 + 1], &c__1);
			    ++jj;
 
			}
			s2 = dnrm2_(&nm, &w[idw], &c__1);
			if (s2 >= epsmch) {
			    k = 1;
			    ipvt[m1] = ni;
			} else {
			    w[ii] = 0.;
			}
		    }
		}
		if (i__ < *md && k == 0) {
		    goto L5000;
		}
	    }
	} else {
	    i__1 = icd + *md - 1;
	    for (i__ = icd; i__ <= i__1; ++i__) {
 
		w[i__] = 0.;
	    }
	}
	i__ = 0;
	if (i__ < midf && k == 0) {
L6000:
	    i1 = i__ + 1;
	    in = nmd + i1;
	    if (ire[in] != 1) {
		ii = iad + i__;
		w[ii] = ddot_(n, &a[i1 * a_dim1 + 1], &c__1, &w[nd], &c__1);
		if (ire[in] == 0 && in != il) {
		    if (i1 <= *mif && (d__1 = w[ii], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > eps || i1 > 
			    *mif && w[ii] > eps && w[in] >= -eps) {

 

 

 

			if (il == 0) {
			    m0 = m1;
			} else {
			    m0 = *m + 2;
			}
			jj = idw;
			i__1 = *n;
			for (i__ = m0; i__ <= i__1; ++i__) {
			    w[jj] = ddot_(n, &q[i__ * q_dim1 + 1], &c__1, &a[
				    i1 * a_dim1 + 1], &c__1);
			    ++jj;
 
			}
			s2 = dnrm2_(&nm, &w[idw], &c__1);

 

 

 

			if (s2 >= epsmch) {
			    k = 1;
			    ipvt[m1] = in;
			} else if (il == 0) {
			    w[ii] = 0.;
			} else {
			    sj = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, &a[i1 * 
				    a_dim1 + 1], &c__1);
			    if ((( sj ) >= 0 ? ( sj ) : -( sj ))  >= epsmch) {
				if (id != 1) {
				    ind1 = 10;
				}
				if (il < 0) {
				    sj = -sj / q[-il + m1 * q_dim1];
				} else if (il <= *n) {
				    sj /= q[il + m1 * q_dim1];
				} else if (il <= nmd) {
				    s2 = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, 
					    &c__[(*mi + il - *n) * c_dim1 + 1]
					    , &c__1);
				    sj /= s2;
				} else {
				    s2 = ddot_(n, &q[m1 * q_dim1 + 1], &c__1, 
					    &a[(il - nmd) * a_dim1 + 1], &
					    c__1);
				    sj /= s2;
				}
				sk = 0.;
				s3 = -1.;
				if (i1 <= *mif) {
				    s2 = (( sj ) >= 0 ? ( sj ) : -( sj )) ;
				    if (il <= nmd || il > nmdi && s < -eps) {
					s3 = s2 + s;
					if (sj > eps) {
					    sk = -1.;
					} else {
					    sk = 1.;
					}
				    } else {
					s3 = s2 - (( s ) >= 0 ? ( s ) : -( s ))  + 1.;
					if (s < -eps && sj > eps || s > eps &&
						 sj < -eps) {
					    sk = -1.;
					} else {
					    sk = 1.;
					}
				    }
				} else {
				    if (sj < -eps && (il <= nmd || il > nmdi 
					    && s < -eps)) {
					s3 = s - sj;
					sk = 1.;
				    } else if (sj > eps && il > nmd && s > 
					    eps) {
					s3 = sj + s1;
					sk = 1.;
				    } else if (sj < -eps && il > nmd && il <= 
					    nmdi && s < -eps) {
					s3 = s1 - sj;
					sk = 1.;
				    }
				}
				if (s3 > eps) {
				    ipvt[m1] = nmd + i1;
				    if (id == 1) {
					id = 2;
					k = 1;
				    } else {
					ind1 = 11;
				    }
				} else if (id == 1) {

 

 

				    if (s > 0.) {
					s1 = -s + 1;
				    } else if (s < 0. && il <= nmdi && il > 
					    nmd) {
					s1 = -s - 1;
				    } else {
					s1 = -s;
				    }
				    s = sk * sj / s1 + 1.;
				    if (info == 0) {
					dscal_(n, &s, &w[nd], &c__1);
				    } else {
					ro = s * ro;
				    }
				    if (sk == 1.) {
					dadd_(n, &a[i1 * a_dim1 + 1], &c__1, &
						w[1], &c__1);
				    } else if (sk == -1.) {
					ddif_(n, &a[i1 * a_dim1 + 1], &c__1, &
						w[1], &c__1);
				    }
				    w[ii] = 0.;
				}
			    } else {
				w[ii] = 0.;
			    }
			}
		    }
		}
	    }
	    i__ = i1;
	    if (i__ < midf && k == 0) {
		goto L6000;
	    }
	}

 

	if (k == 0) {
	    if (id == 0 && *ind <= nm && *ind > 0) {
		id = 2;
	    }
	    if (ind1 == 11 && id != 1) {
		id += 100;
	    }
	    if (ind1 == 10 && id != 1) {
		id += 10;
	    }
	    pasr03_(&a[a_offset], ia, &b[1], &ci[1], &cs[1], &x[1], &ro, &w[1]
		    , &ire[1], &ipvt[m1], ira, n, md, mif, mdf, m, &id, io);
	    if (id == -1) {
		*ind = -1;
		if (*imp >= 7) {
		    dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0,
			     &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, 
			    ind, imp, io, iter);
		}
		return 0;
	    } else if (id == 0) {
		id = 2;
		k = 1;
	    }
	    if (id == 1 || id == 3 || id == 11) {
		icol3 = ipvt[m1];
		if (*imp >= 9) {
		    iadd = icol3;
		}
	    }
	}

 

 

	if (k == 1) {
	    ++icicla;
	    icol3 = ipvt[m1];
	    if (*imp >= 9) {
		iadd = icol3;
	    }
	    if (icicla > *m && *m > 0 || icol3 == icol1 && icol == *m) {
		*ind = -2;
		if (*imp >= 7) {
		    dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &c__0,
			     &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &c__0, 
			    ind, imp, io, iter);
		}
		return 0;
	    }
	    icol1 = icol2;
	    icol2 = icol3;
	} else if (icicla > 0) {
	    icicla = 0;
	    icol1 = 0;
	    icol2 = 0;
	}

 


	if (*imp >= 9) {
	    dimp03_(&x[1], &w[1], &ire[nd1], &ipvt[1], &s, n, &il, m, &midf, &
		    ides, &icicla, &iadd, mi, mi1, &c__2, imp, io, iter);
	}

 

	if (icicla == 0) {
	    i1 = icd - 1;
	    i__1 = *md;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		ni = *n + i__;
		if (ire[ni] == 0 && (iver != iv || iver == -1) && id < 10) {
		    if (ro == 1.) {
			w[ni] += w[i1 + i__];
		    } else {
			w[ni] += ro * w[i1 + i__];
		    }
		}
 
	    }
	    if (ro == 1.) {
		dadd_(n, &w[nd], &c__1, &x[1], &c__1);
	    } else {
		daxpy_(n, &ro, &w[nd], &c__1, &x[1], &c__1);
	    }
	    i1 = nd - 1;
	}

 

 

	if (icicla != 0 || id == 1 || id == 11 || id == 3) {
	    if (il == -icol3) {
		iicol = 1;
	    } else {
		iicol = 0;
	    }
	    s = r__[m2 * r_dim1 + 1];
	    nm1 = nm - 1;
	    *m = m1;
	    if (icol3 < 0) {
		ire[-icol3] = -1;
	    } else {
		ire[icol3] = 1;
	    }
	    if (icol3 <= *n) {
		ip = icol3;
		anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &w[1], 
			&w[nd], &jpvt[1], n, m, &ip, io);
	    } else {
		ip = 0;
		if (icol3 <= nmd) {
		    anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &
			    c__[(*mi + icol3 - *n) * c_dim1 + 1], &w[nd], &
			    jpvt[1], n, m, &ip, io);
		} else {
		    anfm04_(&q[q_offset], iq, &r__[(r_dim1 << 1) + 1], ir, &a[
			    (icol3 - nmd) * a_dim1 + 1], &w[nd], &jpvt[1], n, 
			    m, &ip, io);
		}
	    }

 


	    if (icol3 <= nmd && iver != -1) {
		++iver;
	    }
	    if (nm > 1) {
		if (iibeta == 1 && *ind == -2) {
		    *ind = -1;
		}
		if (*ind > nm << 1 && *ind < nm * 3) {
		    nf = nm * 3 - *ind;
		} else if (*ind > nm && *ind < nm << 1) {
		    nf = (nm << 1) - *ind;
		} else if (*ind < -1 && *ind >= -nm) {
		    nf = -(*ind) - 1;
		} else if (*ind == -1 || *ind == -nm - 1 || *ind == nm * 3 || 
			*ind == nm << 1) {
		    *ind = 0;
		    i__1 = iver - iv;
		    anfm03_(&r__[r_offset], ir, &r__[(*m + 2) * r_dim1 + 1], 
			    ir, &q[(*m + 1) * q_dim1 + 1], iq, &w[nd], &jpvt[
			    1], n, &nm1, ind, &i__1, io);
		    nf = 0;
		} else if (*ind >= 0) {
		    nf = nm;
		} else {
		    nf = -nm - *ind - 1;
		}
		if (nf != 0) {
		    nmf = nm1 - nf;
		    if (*ind > nm) {
			ii = nmf + i1;
		    } else if (*ind < 0) {
			ii = nmf * (nmf + 1) / 2 + i1;
		    }
		    if (iibeta == 1) {
			--nf;
		    }
		    i__1 = iver - iv;
		    anfm05_(&r__[r_offset], ir, &r__[(*m + 2) * r_dim1 + 1], 
			    ir, &q[(*m + 1) * q_dim1 + 1], iq, &w[nd], &w[nd 
			    + (nm1 << 1)], &jpvt[1], &s, &nm1, &nf, n, ind, &
			    i__1, io);
		}
		if (*ind <= -n10) {
		    iibeta = 1;
		    *ind += n10;
		} else {
		    iibeta = 0;
		}
		if (*ind == *n) {
		    *ind = -1;
		    if (*imp >= 7) {
			dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &c__0, &
				c__0, &c__0, &c__0, &c__0, &c__0, &c__0, &
				c__0, &c__0, ind, imp, io, iter);
		    }
		    return 0;
		}
		nm = nm1;
	    }
	}

 

 

	if (icicla == 0 && midf > 0) {
	    i1 = 1;
	    aux003_(&a[a_offset], ia, &x[1], &b[1], &q[q_offset], iq, &r__[(
		    r_dim1 << 1) + 1], ir, &w[nd1], &ire[nd1], &ipvt[1], &nmd,
		     mif, mdf, &midf, n, m, &i1, io);
	    if (i1 == 0) {
		info = 0;
	    }
	}
	if (info == 1 && id != 2) {
	    if (jpvt[nm] != nm || *ind < 0 && *ind != -(*n) && *ind != *n * 
		    -2 + 1 || *ind > *n) {
		info = 0;
	    }
	}

 

 

 

	if (id == 11) {
	    *iw = nd + *m;
	    w[*iw] = opvf03_(&r__[r_offset], ir, &a[a_offset], ia, &p[1], &b[
		    1], &x[1], &w[1], alfa, &nd, n, mif, mdf);
	    *ind = -3;
	    if (*imp >= 7) {
		dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, n, iw, &c__0, &
			c__0, &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io,
			 iter);
	    }
	    return 0;
	}
	if (*m == *n) {
	    minimo = 1;
	    id = 2;
	    nm = 0;
	} else {
	    minimo = 0;
	}
	++(*iter);
	if (*iter <= itemax) {
	    goto L2000;
	}
    }
    *ind = 1;
    if (*imp >= 7) {
	dimp03_(&x[1], &w[1], &ire[1], &ipvt[1], &s, &il, &ides, &c__0, &c__0,
		 &c__0, &c__0, &c__0, &c__0, &c__0, ind, imp, io, iter);
    }
}  

doublereal opvf03_(r__, ir, a, ia, p, b, x, w, alfa, nd, n, mif, mdf)
doublereal *r__;
integer *ir;
doublereal *a;
integer *ia;
doublereal *p, *b, *x, *w, *alfa;
integer *nd, *n, *mif, *mdf;
{
     
    integer r_dim1, r_offset, a_dim1, a_offset, i__1, i__2;
    doublereal ret_val, d__1;

     
    extern doublereal ddot_();
    static integer i__;
    extern   int dscal_();
    static integer i1;
    static doublereal s1;
    static integer ii, ni;
    extern   int dadd_();


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 

 

 

 

 

 


 

 

 

 

 

 

 

 


 
 
 

 
 

     
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --p;
    --b;
    --x;
    --w;

     
    ni = *nd + *n - 1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__ + 1;
	ii = ni + i__;
	w[ii] = ddot_(&i__, &r__[i__ + r_dim1], ir, &x[1], &c__1);
	if (i__ < *n) {
	    i__2 = *n - i__;
	    w[ii] += ddot_(&i__2, &r__[i1 + i__ * r_dim1], &c__1, &x[i1], &
		    c__1);
	}
 
    }
    s1 = .5;
    dscal_(n, &s1, &w[ni + 1], &c__1);
    dadd_(n, &p[1], &c__1, &w[ni + 1], &c__1);
    ret_val = ddot_(n, &x[1], &c__1, &w[ni + 1], &c__1);
    if (*alfa != 1.) {
	ret_val *= *alfa;
    }
    i__1 = *mif;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	ret_val += (d__1 = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1)
		 - b[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    }
    i__1 = *mif + *mdf;
    for (i__ = *mif + 1; i__ <= i__1; ++i__) {
	s1 = ddot_(n, &a[i__ * a_dim1 + 1], &c__1, &x[1], &c__1) - b[i__];
	if (s1 > 0.) {
	    ret_val += s1;
	}
 
    }
    return ret_val;
}  

  int pasr03_(a, ia, b, ci, cs, x, ro, w, ire, ipvt, ira, n, 
	md, mif, mdf, m, id, io)
doublereal *a;
integer *ia;
doublereal *b, *ci, *cs, *x, *ro, *w;
integer *ire, *ipvt, *ira, *n, *md, *mif, *mdf, *m, *id, *io;
{
     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1;

     
    double pow_dd(), sqrt();

     
    extern doublereal ddot_(), dnrm0_();
    static integer i__, j, k, l;
    static doublereal s, delta;
    static integer i1, i2, k1, j1;
    static doublereal s0, r1, r2, r3, s1;
    static integer nd, ii;
    static doublereal sd;
    extern doublereal dlamch_();
    static integer ip, ni;
    static doublereal gigant;
    static integer id1, nd0, nd1, ip3;
    static doublereal ro1;
    static integer idi, ndf, nmd, iip;
    static doublereal eps;
    static integer iad0, icd0;
    static doublereal gig1;
    static integer ind1;


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 
 

 
 

 


 

 

 

 

 

 

 

 


 
 

 
 

 
 



 

     
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --b;
    --ci;
    --cs;
    --x;
    --w;
    --ire;
    --ipvt;

     
    nmd = *n + *md;
    nd1 = nmd + 1;
    ndf = nmd + *mif;
    nd0 = ndf + *mdf;
    nd = nd0 + 1;
    icd0 = nd0 + *n;
    iad0 = icd0 + *md;
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);
    gigant = dlamch_("o", 1L);
    gig1 = sqrt(gigant);
    ind1 = 0;
    if (*id >= 100) {
	ind1 = 2;
	*id += -100;
    } else if (*id >= 10) {
	ind1 = 1;
	*id += -10;
    }
    idi = *id;
    if (*id != 1) {
	sd = dnrm0_(n, &w[nd], &c__1) + 1;
	delta = 1e8;
    } else {
	s0 = *ro;
    }
    r1 = 0.;
    r2 = gigant;
    k = 0;

 
 

    if (*ira > 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ii = nd0 + i__;
	    j = 0;
	    if (*ira > 1) {
		if (cs[i__] <= gig1 && (ire[i__] == 0 && w[ii] > eps)) {
		    s = (cs[i__] - x[i__]) / w[ii];
		    if (s < r2 && s > r1) {
			r2 = s;
			ip = i__;
		    }
		    j = 1;
		}
	    }
	    if (j == 0 && *ira != 2) {
		if (ci[i__] >= -gig1 && (ire[i__] == 0 && w[ii] < -eps)) {
		    s = (ci[i__] - x[i__]) / w[ii];
		    if (s < r2 && s > r1) {
			ip = -i__;
			r2 = s;
		    }
		}
	    }
 
	}
    }
    i__1 = *md;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ni = *n + i__;
	i2 = icd0 + i__;
	if (ire[ni] == 0) {
	    if (w[i2] > eps) {
		s = -w[ni] / w[i2];
		if (s <= r2 && s > r1) {
		    r2 = s;
		    ip = ni;
		}
	    }
	}
 
    }

 

    if (r2 == gigant && *id == 0) {
	*id = -1;
	return 0;
    }

 

 

    r3 = r2;
    *ro = r2;
    i__1 = *mif;
    for (i__ = 1; i__ <= i__1; ++i__) {
	k1 = k + 1;
	ni = nmd + i__;
	ii = iad0 + i__;
	if ((i__2 = ire[ni], (( i__2 ) >= 0 ? ( i__2 ) : -( i__2 )) ) == 2) {
	    s = w[ii];
	}
	if (ire[ni] == 2 && s < -eps || ire[ni] == -2 && s > eps) {
	    s1 = -w[ni] / s;
	    if (s1 <= r2 && s1 > r1) {
		if (r3 == gigant && *id == 2) {
		    w[nmd + k1] = s1;
		    k = k1;
		    ipvt[k] = ni;
		    if (s1 < *ro) {
			*ro = s1;
			ip = ni;
		    }
		} else {
		    r2 = s1;
		    ip3 = ni;
		}
	    }
	}
 
    }
    i__1 = *mdf;
    for (i__ = 1; i__ <= i__1; ++i__) {
	k1 = k + 1;
	ni = ndf + i__;
	if (ire[ni] != 1) {
	    s = w[iad0 + *mif + i__];
	}
	if (ire[ni] == 2 && s < -eps || ire[ni] == 0 && s > eps) {
	    s1 = -w[ni] / s;
	    if (s1 <= r2 && s1 > r1) {
		if (r3 == gigant && *id == 2) {
		    w[nmd + k1] = s1;
		    k = k1;
		    ipvt[k] = ni;
		    if (s1 < *ro) {
			*ro = s1;
			ip = ni;
		    }
		} else {
		    r2 = s1;
		    ip3 = ni;
		}
	    }
	}
 
    }

 

    if (r3 == gigant && *id == 2) {
	s = ddot_(n, &w[1], &c__1, &w[nd], &c__1);
	if (k > 0) {
	    id1 = iad0 - nmd;
	    ro1 = 0.;
	    if (s < -eps && ro1 < r2) {
L5010:
		l = 0;
		r1 = ro1;
		ro1 = r2;
		i__1 = k;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    ii = nmd + i__;
		    if (w[ii] <= ro1 && w[ii] > r1) {
			if (w[ii] < ro1) {
			    l = 0;
			}
			ro1 = w[ii];
			w[ii] = w[nd1 + l];
			w[nd1 + l] = ro1;
			++l;
			j = ipvt[i__];
			ipvt[i__] = ipvt[l];
			ipvt[l] = j;
		    }
 
		}

 

 

 

		i__1 = l;
		for (i__ = 1; i__ <= i__1; ++i__) {
		    j = ipvt[i__];
		    ii = i__ - 1;
		    i1 = nmd + i__;
		    j1 = j - nmd;
		    if (j <= ndf) {
			if (ire[j] == 2) {
			    s -= w[j + id1] * 2;
			} else if (ire[j] == -2) {
			    s += w[j + id1] * 2;
			}
		    } else {
			if (ire[j] == 0) {
			    s += w[j + id1];
			} else if (ire[j] == 2) {
			    s -= w[j + id1];
			}
		    }
 
		}
		if (s >= -eps && ind1 == 1) {
		    iip = ipvt[*m + 1] - nmd;
		    s1 = ddot_(n, &w[nd], &c__1, &a[iip * a_dim1 + 1], &c__1);
		    if (iip > ndf || s1 > eps) {
			s += s1;
		    }
		    ind1 = 11;
		}
		if (s < -eps && ro1 < r2) {
		    goto L5010;
		}
	    }
	}
	if (s < -eps) {
	    *id = -1;
	    return 0;
	} else {
	    if (ind1 == 2) {
		*id = 0;
		return 0;
	    } else {
		ipvt[1] = ip;
		*id = 1;
	    }
	}
    } else {
	if (r2 < r3) {
	    ip = ip3;
	}
	if (*id == 1) {
	    s = (( r2 ) <= ( s0 ) ? ( r2 ) : ( s0 )) ;
	    if (s == s0) {
		*id = 2;
		if (r2 == s0) {
		    *id = 3;
		    ipvt[1] = ip;
		}
	    } else {
		ipvt[1] = ip;
	    }
	    *ro = s;
	} else {
	    if (ind1 == 2) {
		*id = 0;
		return 0;
	    }
	    *ro = r2;
	    *id = 1;
	    ipvt[1] = ip;
	}
    }

 

 

    if (idi != 1) {
	s = *ro * sd;
	if (s > delta) {
	    *id += 10;
	}
    }
}  

  int plcbas_(h__, p, c__, d__, ci, cs, ira, mi, md, x, f, w, 
	iv, lagr, imp, io, n, modo, info)
doublereal *h__, *p, *c__, *d__, *ci, *cs;
integer *ira, *mi, *md;
doublereal *x, *f, *w;
integer *iv;
doublereal *lagr;
integer *imp, *io, *n, *modo, *info;
{
     
    integer h_dim1, h_offset, c_dim1, c_offset, i__1, i__2;

     
    integer s_wsfe(), e_wsfe();

     
    static doublereal alfa;
    static integer nmid, iter, nmul, modo1;
    static doublereal b;
    static integer i__, j, k, m;
    extern   int dcopy_(), optr03_();
    static integer n1, nipvt, njpvt, nl, iw, nw, mi1, mdf, mid, ind, mif, nmd;

     
    static cilist io___2949 = { 0, 0, 0, "(/10X,'START  OF PLCBAS ')", 0 };


 
 

 

 

 
 


 
 

 

 

 

 

 

 

 

 

 

 

 

 


     
    --p;
    --d__;
    --ci;
    --cs;
    --x;
    --w;
    --iv;
    --lagr;
    c_dim1 = *n;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    h_dim1 = *n;
    h_offset = h_dim1 + 1;
    h__ -= h_offset;

     
    if (*imp > 6) {
	io___2949.ciunit = *io;
	s_wsfe(&io___2949);
	e_wsfe();
    }
    iw = 1;
    alfa = 1.;
    mif = 0;
    mdf = 0;
    n1 = *n + 1;
    k = n1;
    mid = *mi + *md;
    nmd = *n + *md;
    nmid = *n + mid;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	--k;
	j = *n * (i__ - 1) + i__;
	dcopy_(&k, &h__[i__ + i__ * h_dim1], &c__1, &w[j], &c__1);
 
    }
    nipvt = nmd + 1;
    njpvt = nipvt + nmid + 1;
    nw = *n * n1 + 1;
    modo1 = *modo;
    if (*modo == 1) {
	*modo = 6;
    }
    if (*modo == 2) {
	*modo = 1;
    }
    if (*modo == 3) {
	*modo = 2;
    }
    optr03_(&w[1], &c__1, &c__[c_offset], n, &h__[h_offset], n, &w[1], n, &p[
	    1], &b, &d__[1], &ci[1], &cs[1], &x[1], &w[nw], &iw, &iv[1], &iv[
	    nipvt], &iv[njpvt], &alfa, ira, n, &m, mi, &mi1, md, &mif, &mdf, 
	    modo, &ind, imp, io, &iter);
    *modo = modo1;
    *info = ind;
    k = n1;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	--k;
	j = *n * (i__ - 1) + i__;
	dcopy_(&k, &w[j], &c__1, &h__[i__ + i__ * h_dim1], &c__1);
 
    }
    i__1 = *n;
    for (j = 2; j <= i__1; ++j) {
	i__2 = j - 1;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    h__[i__ + j * h_dim1] = h__[j + i__ * h_dim1];
	}
 
    }
    if (ind != 0) {
	return 0;
    }
    if (ind == 0) {
	*f = w[nw + iw - 1];
	nmul = nmd + nw;
	if (*ira > 0) {
	    nl = *n;
	} else {
	    nl = 0;
	}
	i__1 = nl + mid;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    lagr[i__] = 0.;
	}
	k = nipvt;
	i__1 = mi1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    j = iv[k] + nl;
	    lagr[j] = w[nmul];
	    ++nmul;
	    ++k;
 
	}
	i__1 = m;
	for (i__ = mi1 + 1; i__ <= i__1; ++i__) {
	    j = iv[k];
	    if (j < 0) {
		lagr[-j] = -w[nmul];
	    } else if (j <= *n) {
		lagr[j] = w[nmul];
	    } else {
		if (*ira == 0) {
		    j -= *n;
		}
		lagr[j + *mi] = w[nmul];
	    }
	    ++nmul;
	    ++k;
 
	}
    }
}  

  int proj_(n, binf, bsup, x)
integer *n;
doublereal *binf, *bsup, *x;
{
     
    integer i__1;
    doublereal d__1, d__2, d__3, d__4;

     
    static integer i__;

     
    --x;
    --bsup;
    --binf;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
 
	d__3 = x[i__], d__4 = bsup[i__];
	d__1 = binf[i__], d__2 = (( d__3 ) <= ( d__4 ) ? ( d__3 ) : ( d__4 )) ;
	x[i__] = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    }
    return 0;
}  

  int qform_(m, n, q, ldq, wa)
integer *m, *n;
doublereal *q;
integer *ldq;
doublereal *wa;
{
     

    static doublereal one = 1.;
    static doublereal zero = 0.;

     
    integer q_dim1, q_offset, i__1, i__2, i__3;

     
    static doublereal temp;
    static integer i__, j, k, l, minmn, jm1, np1;
    static doublereal sum;

 

 

 
 
 

 

 

 

 
 

 
 

 
 
 

 
 

 

 

 

 
 

 
     
    --wa;
    q_dim1 = *ldq;
    q_offset = q_dim1 + 1;
    q -= q_offset;

     

 

    minmn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    if (minmn < 2) {
	goto L30;
    }
    i__1 = minmn;
    for (j = 2; j <= i__1; ++j) {
	jm1 = j - 1;
	i__2 = jm1;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    q[i__ + j * q_dim1] = zero;
 
	}
 
    }
L30:

 

    np1 = *n + 1;
    if (*m < np1) {
	goto L60;
    }
    i__1 = *m;
    for (j = np1; j <= i__1; ++j) {
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    q[i__ + j * q_dim1] = zero;
 
	}
	q[j + j * q_dim1] = one;
 
    }
L60:

 

    i__1 = minmn;
    for (l = 1; l <= i__1; ++l) {
	k = minmn - l + 1;
	i__2 = *m;
	for (i__ = k; i__ <= i__2; ++i__) {
	    wa[i__] = q[i__ + k * q_dim1];
	    q[i__ + k * q_dim1] = zero;
 
	}
	q[k + k * q_dim1] = one;
	if (wa[k] == zero) {
	    goto L110;
	}
	i__2 = *m;
	for (j = k; j <= i__2; ++j) {
	    sum = zero;
	    i__3 = *m;
	    for (i__ = k; i__ <= i__3; ++i__) {
		sum += q[i__ + j * q_dim1] * wa[i__];
 
	    }
	    temp = sum / wa[k];
	    i__3 = *m;
	    for (i__ = k; i__ <= i__3; ++i__) {
		q[i__ + j * q_dim1] -= temp * wa[i__];
 
	    }
 
	}
L110:
 
	;
    }
    return 0;

 

}  

  int qnbd_(indqn, simul, n, x, f, g, imp, io, zero, napmax, 
	itmax, epsf, epsg, epsx, df0, binf, bsup, nfac, trav, ntrav, itrav, 
	nitrav, izs, rzs, dzs)
integer *indqn;
  int (*simul) ();
integer *n;
doublereal *x, *f, *g;
integer *imp, *io;
doublereal *zero;
integer *napmax, *itmax;
doublereal *epsf, *epsg, *epsx, *df0, *binf, *bsup;
integer *nfac;
doublereal *trav;
integer *ntrav, *itrav, *nitrav, *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1010[] = "(\002 *********** qnbd ****************\002)";
    static char fmt_110[] = "(\002 qnbd : ntrav=\002,i8,\002 devrait valoir \002,i8)";
    static char fmt_111[] = "(\002 qnbd : nitrav=\002,i8,\002devrait valoir\002,i8)";

     
    integer s_wsfe(), e_wsfe(), do_fio();

     
    static integer iact, izag, irel, ieps1;
    extern   int zqnbd_();
    static integer n1, n2, n3, n4, n5, ig, in;
    static doublereal epsrel;
    static integer ni1, ni2;

     
    static cilist io___2984 = { 0, 0, 0, fmt_1010, 0 };
    static cilist io___2997 = { 0, 0, 0, fmt_110, 0 };
    static cilist io___3000 = { 0, 0, 0, fmt_111, 0 };


 
 
 
 
 
 

 

 
 
 


     
    --bsup;
    --binf;
    --epsx;
    --g;
    --x;
    --trav;
    --itrav;
    --izs;
    --rzs;
    --dzs;

     
    if (*imp >= 1) {
	io___2984.ciunit = *io;
	s_wsfe(&io___2984);
	e_wsfe();
    }


 
 
 
 
 
 
 
 
 
    ig = 0;
    in = 0;
    irel = 1;
    epsrel = .5;
    izag = 0;
    iact = 1;
    ieps1 = 0;

 
    n1 = *n * (*n + 1) / 2 + 1;
    n2 = n1 + *n;
    n3 = n2 + *n;
    n4 = n3 + *n;
    n5 = n4 + *n - 1;
    if (*ntrav < n5) {
	if (*imp > 0) {
	    io___2997.ciunit = *io;
	    s_wsfe(&io___2997);
	    do_fio(&c__1, (char *)&(*ntrav), (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&n5, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*indqn = -11;
	return 0;
    }
    ni1 = *n + 1;
    if (*nitrav < *n << 1) {
	ni2 = *n << 1;
	if (*imp > 0) {
	    io___3000.ciunit = *io;
	    s_wsfe(&io___3000);
	    do_fio(&c__1, (char *)&(*nitrav), (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&ni2, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*indqn = -12;
	return 0;
    }
    zqnbd_(indqn, simul, &trav[1], n, &binf[1], &bsup[1], &x[1], f, &g[1], 
	    zero, napmax, itmax, &itrav[1], &itrav[ni1], nfac, imp, io, &epsx[
	    1], epsf, epsg, &trav[n1], &trav[n2], &trav[n3], &trav[n4], df0, &
	    ig, &in, &irel, &izag, &iact, &epsrel, &ieps1, &izs[1], &rzs[1], &
	    dzs[1]);
    return 0;
}  

  int qrfac_(m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm, 
	wa)
integer *m, *n;
doublereal *a;
integer *lda;
logical *pivot;
integer *ipvt, *lipvt;
doublereal *rdiag, *acnorm, *wa;
{
     

    static doublereal one = 1.;
    static doublereal p05 = .05;
    static doublereal zero = 0.;

     
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1, d__2, d__3;

     
    double sqrt();

     
    static integer kmax;
    static doublereal temp;
    static integer i__, j, k, minmn;
    extern doublereal enorm_(), dlamch_();
    static doublereal epsmch, ajnorm;
    static integer jp1;
    static doublereal sum;
     
    --wa;
    --acnorm;
    --rdiag;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --ipvt;

     

 

    epsmch = dlamch_("p", 1L);

 

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	acnorm[j] = enorm_(m, &a[j * a_dim1 + 1]);
	rdiag[j] = acnorm[j];
	wa[j] = rdiag[j];
	if (*pivot) {
	    ipvt[j] = j;
	}
 
    }

 

    minmn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    i__1 = minmn;
    for (j = 1; j <= i__1; ++j) {
	if (! (*pivot)) {
	    goto L40;
	}

 

	kmax = j;
	i__2 = *n;
	for (k = j; k <= i__2; ++k) {
	    if (rdiag[k] > rdiag[kmax]) {
		kmax = k;
	    }
 
	}
	if (kmax == j) {
	    goto L40;
	}
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    temp = a[i__ + j * a_dim1];
	    a[i__ + j * a_dim1] = a[i__ + kmax * a_dim1];
	    a[i__ + kmax * a_dim1] = temp;
 
	}
	rdiag[kmax] = rdiag[j];
	wa[kmax] = wa[j];
	k = ipvt[j];
	ipvt[j] = ipvt[kmax];
	ipvt[kmax] = k;
L40:

 
 

	i__2 = *m - j + 1;
	ajnorm = enorm_(&i__2, &a[j + j * a_dim1]);
	if (ajnorm == zero) {
	    goto L100;
	}
	if (a[j + j * a_dim1] < zero) {
	    ajnorm = -ajnorm;
	}
	i__2 = *m;
	for (i__ = j; i__ <= i__2; ++i__) {
	    a[i__ + j * a_dim1] /= ajnorm;
 
	}
	a[j + j * a_dim1] += one;

 
 

	jp1 = j + 1;
	if (*n < jp1) {
	    goto L100;
	}
	i__2 = *n;
	for (k = jp1; k <= i__2; ++k) {
	    sum = zero;
	    i__3 = *m;
	    for (i__ = j; i__ <= i__3; ++i__) {
		sum += a[i__ + j * a_dim1] * a[i__ + k * a_dim1];
 
	    }
	    temp = sum / a[j + j * a_dim1];
	    i__3 = *m;
	    for (i__ = j; i__ <= i__3; ++i__) {
		a[i__ + k * a_dim1] -= temp * a[i__ + j * a_dim1];
 
	    }
	    if (! (*pivot) || rdiag[k] == zero) {
		goto L80;
	    }
	    temp = a[j + k * a_dim1] / rdiag[k];
 
 
	    d__3 = temp;
	    d__1 = zero, d__2 = one - d__3 * d__3;
	    rdiag[k] *= sqrt(((( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ));
 
	    d__1 = rdiag[k] / wa[k];
	    if (p05 * (d__1 * d__1) > epsmch) {
		goto L80;
	    }
	    i__3 = *m - j;
	    rdiag[k] = enorm_(&i__3, &a[jp1 + k * a_dim1]);
	    wa[k] = rdiag[k];
L80:
 
	    ;
	}
L100:
	rdiag[j] = -ajnorm;
 
    }
    return 0;

 

}  

  int r1mpyq_(m, n, a, lda, v, w)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *v, *w;
{
     

    static doublereal one = 1.;

     
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt();

     
    static doublereal temp;
    static integer i__, j, nm1, nmj;
    static doublereal cos__, sin__;

 

 

 
 

 

 
 
 
 

 

 

 

 
 

 
 

 
 
 

 
 

 
 
 

 
 
 

 

 

 
 

 
     
    --w;
    --v;
    a_dim1 = *lda;
    a_offset = a_dim1 + 1;
    a -= a_offset;

     

 

    nm1 = *n - 1;
    if (nm1 < 1) {
	goto L50;
    }
    i__1 = nm1;
    for (nmj = 1; nmj <= i__1; ++nmj) {
	j = *n - nmj;
	if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) {
	    cos__ = one / v[j];
	}
	if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) {
 
	    d__2 = cos__;
	    sin__ = sqrt(one - d__2 * d__2);
	}
	if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) {
	    sin__ = v[j];
	}
	if ((d__1 = v[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) {
 
	    d__2 = sin__;
	    cos__ = sqrt(one - d__2 * d__2);
	}
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    temp = cos__ * a[i__ + j * a_dim1] - sin__ * a[i__ + *n * a_dim1];
	    a[i__ + *n * a_dim1] = sin__ * a[i__ + j * a_dim1] + cos__ * a[
		    i__ + *n * a_dim1];
	    a[i__ + j * a_dim1] = temp;
 
	}
 
    }

 

    i__1 = nm1;
    for (j = 1; j <= i__1; ++j) {
	if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) {
	    cos__ = one / w[j];
	}
	if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > one) {
 
	    d__2 = cos__;
	    sin__ = sqrt(one - d__2 * d__2);
	}
	if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) {
	    sin__ = w[j];
	}
	if ((d__1 = w[j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= one) {
 
	    d__2 = sin__;
	    cos__ = sqrt(one - d__2 * d__2);
	}
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    temp = cos__ * a[i__ + j * a_dim1] + sin__ * a[i__ + *n * a_dim1];
	    a[i__ + *n * a_dim1] = -sin__ * a[i__ + j * a_dim1] + cos__ * a[
		    i__ + *n * a_dim1];
	    a[i__ + j * a_dim1] = temp;
 
	}
 
    }
L50:
    return 0;

 

}  

  int r1updt_(m, n, s, ls, u, v, w, sing)
integer *m, *n;
doublereal *s;
integer *ls;
doublereal *u, *v, *w;
logical *sing;
{
     

    static doublereal one = 1.;
    static doublereal p5 = .5;
    static doublereal p25 = .25;
    static doublereal zero = 0.;

     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt();

     
    static doublereal temp;
    static integer i__, j, l;
    static doublereal giant, cotan;
    static integer jj;
    extern doublereal dlamch_();
    static integer nm1;
    static doublereal tan__;
    static integer nmj;
    static doublereal cos__, sin__, tau;

 

 

 
 
 

 
 

 

 
 

 

 
 
 
 

 

 

 

 
 

 
 

 
 
 

 
 

 
 

 
 
 

 
 
 

 
 
 

 

 

 

 
 
 

 
     
    --w;
    --u;
    --v;
    --s;

     

 

    giant = dlamch_("o", 1L);

 

    jj = *n * ((*m << 1) - *n + 1) / 2 - (*m - *n);

 

    l = jj;
    i__1 = *m;
    for (i__ = *n; i__ <= i__1; ++i__) {
	w[i__] = s[l];
	++l;
 
    }

 
 

    nm1 = *n - 1;
    if (nm1 < 1) {
	goto L70;
    }
    i__1 = nm1;
    for (nmj = 1; nmj <= i__1; ++nmj) {
	j = *n - nmj;
	jj -= *m - j + 1;
	w[j] = zero;
	if (v[j] == zero) {
	    goto L50;
	}

 
 

	if ((d__1 = v[*n], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= (d__2 = v[j], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	    goto L20;
	}
	cotan = v[*n] / v[j];
 
	d__1 = cotan;
	sin__ = p5 / sqrt(p25 + p25 * (d__1 * d__1));
	cos__ = sin__ * cotan;
	tau = one;
	if ((( cos__ ) >= 0 ? ( cos__ ) : -( cos__ ))  * giant > one) {
	    tau = one / cos__;
	}
	goto L30;
L20:
	tan__ = v[j] / v[*n];
 
	d__1 = tan__;
	cos__ = p5 / sqrt(p25 + p25 * (d__1 * d__1));
	sin__ = cos__ * tan__;
	tau = sin__;
L30:

 
 

	v[*n] = sin__ * v[j] + cos__ * v[*n];
	v[j] = tau;

 

	l = jj;
	i__2 = *m;
	for (i__ = j; i__ <= i__2; ++i__) {
	    temp = cos__ * s[l] - sin__ * w[i__];
	    w[i__] = sin__ * s[l] + cos__ * w[i__];
	    s[l] = temp;
	    ++l;
 
	}
L50:
 
	;
    }
L70:

 

    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	w[i__] += v[*n] * u[i__];
 
    }

 

    *sing = (0) ;
    if (nm1 < 1) {
	goto L140;
    }
    i__1 = nm1;
    for (j = 1; j <= i__1; ++j) {
	if (w[j] == zero) {
	    goto L120;
	}

 
 

	if ((d__1 = s[jj], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= (d__2 = w[j], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	    goto L90;
	}
	cotan = s[jj] / w[j];
 
	d__1 = cotan;
	sin__ = p5 / sqrt(p25 + p25 * (d__1 * d__1));
	cos__ = sin__ * cotan;
	tau = one;
	if ((( cos__ ) >= 0 ? ( cos__ ) : -( cos__ ))  * giant > one) {
	    tau = one / cos__;
	}
	goto L100;
L90:
	tan__ = w[j] / s[jj];
 
	d__1 = tan__;
	cos__ = p5 / sqrt(p25 + p25 * (d__1 * d__1));
	sin__ = cos__ * tan__;
	tau = sin__;
L100:

 

	l = jj;
	i__2 = *m;
	for (i__ = j; i__ <= i__2; ++i__) {
	    temp = cos__ * s[l] + sin__ * w[i__];
	    w[i__] = -sin__ * s[l] + cos__ * w[i__];
	    s[l] = temp;
	    ++l;
 
	}

 
 

	w[j] = tau;
L120:

 

	if (s[jj] == zero) {
	    *sing = (1) ;
	}
	jj += *m - j + 1;
 
    }
L140:

 

    l = jj;
    i__1 = *m;
    for (i__ = *n; i__ <= i__1; ++i__) {
	s[l] = w[i__];
	++l;
 
    }
    if (s[jj] == zero) {
	*sing = (1) ;
    }
    return 0;

 

}  

doublereal rednor_(n, binf, bsup, x, epsx, g)
integer *n;
doublereal *binf, *bsup, *x, *epsx, *g;
{
     
    integer i__1;
    doublereal ret_val, d__1;

     
    double sqrt();

     
    static integer i__;
    static doublereal aa;

     
    --g;
    --epsx;
    --x;
    --bsup;
    --binf;

     
    ret_val = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	aa = g[i__];
	if (x[i__] - binf[i__] <= epsx[i__]) {
	    aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ;
	}
	if (bsup[i__] - x[i__] <= epsx[i__]) {
	    aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ;
	}
 
 
	d__1 = aa;
	ret_val += d__1 * d__1;
    }
    ret_val = sqrt(ret_val);
    return ret_val;
}  

 
  int relvar_(ind, n, x, binf, bsup, x2, g, diag, imp, io, 
	ibloc, izag, iter, nfac, irit)
integer *ind, *n;
doublereal *x, *binf, *bsup, *x2, *g, *diag;
integer *imp, *io, *ibloc, *izag, *iter, *nfac, *irit;
{
     
    static char fmt_322[] = "(\002 relvar1. valeur de eps1=\002,d15.7)";
    static char fmt_336[] = "(\002 defactorisation de x(\002,i3,\002)=\002,d15.7)";
    static char fmt_339[] = "(\002 on factorise l indice \002,i3)";
    static char fmt_350[] = "(\002 relvar1 . nbre fact\002,i3,\002 nbre defact\002,i3,\002 nbre var     factorisees\002,i3)";

     
    integer i__1;
    doublereal d__1;

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static integer ifac;
    static doublereal frac;
    extern   int proj_();
    static integer izag1, idfac, i__, k;
    static doublereal d1, d2, dd, bi, bs, ep, eps1;

     
    static cilist io___3043 = { 0, 0, 0, fmt_322, 0 };
    static cilist io___3054 = { 0, 0, 0, fmt_336, 0 };
    static cilist io___3056 = { 0, 0, 0, fmt_339, 0 };
    static cilist io___3057 = { 0, 0, 0, fmt_350, 0 };


 
 
 
 

 
     
    --ibloc;
    --diag;
    --g;
    --x2;
    --bsup;
    --binf;
    --x;

     
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x2[i__] = x[i__] - (d__1 = g[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * g[i__] / diag[i__];
    }
    proj_(n, &binf[1], &bsup[1], &x2[1]);
    eps1 = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	eps1 += (d__1 = x2[i__] - x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    }
    if (*imp > 2) {
	io___3043.ciunit = *io;
	s_wsfe(&io___3043);
	do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
    ifac = 0;
    idfac = 0;
    k = 0;
    frac = (float).10000000000000001;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	bi = binf[k];
	bs = bsup[k];
	d1 = x[k] - bi;
	d2 = bs - x[k];
	dd = (bs - bi) * frac;
	ep = (( eps1 ) <= ( dd ) ? ( eps1 ) : ( dd )) ;
	if (d1 > ep) {
	    goto L324;
	}
	if (g[k] > (float)0.) {
	    goto L330;
	}
	goto L335;
L324:
	if (d2 > ep) {
	    goto L335;
	}
	if (g[k] > (float)0.) {
	    goto L335;
	}
	goto L330;
 
L330:
	if (ibloc[k] > 0) {
	    goto L340;
	}
	ibloc[k] = *iter;
	++idfac;
	--(*nfac);
	*ind = 1;
	if (*imp >= 4) {
	    io___3054.ciunit = *io;
	    s_wsfe(&io___3054);
	    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&x[k], (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	goto L340;
 
L335:
	if (*irit == 0) {
	    goto L340;
	}
	if (ibloc[k] <= 0) {
	    goto L340;
	}
	izag1 = *iter - ibloc[k];
	if (*izag >= izag1) {
	    goto L340;
	}
	++ifac;
	++(*nfac);
	ibloc[k] = -(*iter);
	if (*imp >= 4) {
	    io___3056.ciunit = *io;
	    s_wsfe(&io___3056);
	    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
L340:
	;
    }
    if (*imp >= 2 && (ifac > 0 || idfac > 0)) {
	io___3057.ciunit = *io;
	s_wsfe(&io___3057);
	do_fio(&c__1, (char *)&ifac, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&idfac, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nfac), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    *ind = 1;
    if (ifac == 0 && idfac == 0) {
	*ind = 0;
    }
    return 0;
}  

  int rlbd_(indrl, n, simul, x, binf, bsup, f, hp, t, tmax, 
	d__, gn, tproj, amd, amf, imp, io, zero, nap, napmax, xn, izs, rzs, 
	dzs)
integer *indrl, *n;
  int (*simul) ();
doublereal *x, *binf, *bsup, *f, *hp, *t, *tmax, *d__, *gn, *tproj, *amd, *
	amf;
integer *imp, *io;
doublereal *zero;
integer *nap, *napmax;
doublereal *xn;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_14050[] = "(\002 rlbd tp=\002,e11.4,\002 tmax=\002,e11.4,\002 dh0/dt=\002,e11.4)";
    static char fmt_15000[] = "(a3,\002 t=\002,e11.4,\002 h=\002,e11.4,\002 dh/dt=\002,e11.4,\002 dfh/dt=\002,e11.4,\002 dt\002,e8.1)";
    static char fmt_15020[] = "(3x,\002 t=\002,e11.4,\002 h=\002,e11.4,\002 dh/dt=\002,e11.4,\002 dfh/dt=\002,e11.4,\002 dt\002,e8.1)";
    static char fmt_16000[] = "(\002 rlbd : sortie du domaine : indic=\002,i2,\002  t=\002,e11.4)";
    static char fmt_3330[] = "(\002toutes les variables sont saturees:tmaxp= \002,e11.4)";

     
    integer i__1;
    doublereal d__1, d__2;

     
      int s_copy();
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static integer icoi, icop, icos, imax;
    static doublereal hptd, hptg;
    extern   int proj_();
    static doublereal epst, text, topt, hpta1, a, b, e;
    static integer i__, k;
    static doublereal p, r__;
    static integer indic;
    static doublereal difhp, a1, extra;
    static integer iproj;
    static doublereal f0, tmaxp, h1, ttmin;
    extern   int satur_();
    static doublereal extrp, t1, t2, ttsup, fa, f11, di, fn, ta, td, tg, 
	    cofder, fa1, ta1, hpa, hpd, ftd, hpg, ftg, div, hpn, eps, tmi, 
	    xni;
    static integer ico1;
    static doublereal eps1;
    static char var2[3];

     
    static cilist io___3079 = { 0, 0, 0, fmt_14050, 0 };
    static cilist io___3083 = { 0, 0, 0, fmt_16000, 0 };
    static cilist io___3089 = { 0, 0, 0, fmt_3330, 0 };
    static cilist io___3114 = { 0, 0, 0, fmt_15000, 0 };
    static cilist io___3115 = { 0, 0, 0, fmt_15020, 0 };



 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --xn;
    --gn;
    --d__;
    --bsup;
    --binf;
    --x;
    --izs;
    --rzs;
    --dzs;

     
    *indrl = 1;
    eps1 = .9;
    eps = .1;
    epst = .1;
    extrp = 100.;
    extra = 10.;
    cofder = (float)100.;
    s_copy(var2, "   ", 3L, 3L);

    ta1 = 0.;
    f0 = *f;
    fa1 = *f;
    hpta1 = *hp;
    imax = 0;
    hptg = *hp;
    ftg = *f;
    tg = 0.;
    td = 0.;
    icos = 0;
    icoi = 0;
    icop = 0;

 
    *tproj = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = d__[i__]) < 0.) {
	    goto L4;
	} else if (d__1 == 0) {
	    goto L7;
	} else {
	    goto L5;
	}
L4:
	t2 = (binf[i__] - x[i__]) / d__[i__];
	goto L6;
L5:
	t2 = (bsup[i__] - x[i__]) / d__[i__];
L6:
	if (t2 <= 0.) {
	    goto L7;
	}
	if (*tproj == 0.) {
	    *tproj = t2;
	}
	if (t2 > *tproj) {
	    goto L7;
	}
	*tproj = t2;
	icop = i__;
L7:
	;
    }

    if (*imp >= 3) {
	io___3079.ciunit = *io;
	s_wsfe(&io___3079);
	do_fio(&c__1, (char *)&(*tproj), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*tmax), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*hp), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
 
 

 

 
L200:
    if (*nap >= *napmax) {
	k = 3;
	goto L1000;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] = x[i__] + *t * d__[i__];
    }
    proj_(n, &binf[1], &bsup[1], &xn[1]);
    if (icos > 0) {
	xn[icos] = bsup[icos];
    }
    if (icoi > 0) {
	xn[icoi] = binf[icoi];
    }
    indic = 4;
    (*simul)(&indic, n, &xn[1], &fn, &gn[1], &izs[1], &rzs[1], &dzs[1]);
    ++(*nap);
    if (indic < 0) {
	if (*imp >= 3) {
	    io___3083.ciunit = *io;
	    s_wsfe(&io___3083);
	    do_fio(&c__1, (char *)&indic, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	if (*nap >= *napmax) {
	    goto L1000;
	}
	*t = tg + (*t - tg) / 4.;
	*tmax = *t;
	imax = 1;
	icoi = 0;
	icos = 0;
	s_copy(var2, "dd ", 3L, 3L);
	goto L800;
    }
    if (indic == 0) {
	*indrl = 0;
	goto L1010;
    }

 
    hpg = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	xn[i__] = x[i__] + *t * d__[i__];
    }
    if (icoi > 0) {
	xn[icoi] = bsup[icoi];
    }
    if (icos > 0) {
	xn[icos] = bsup[icos];
    }
    proj_(n, &binf[1], &bsup[1], &xn[1]);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	xni = xn[i__];
 
	if (binf[i__] < xni && xni < bsup[i__]) {
	    hpg += d__[i__] * gn[i__];
	}
    }
    hpd = hpg;
    if (icoi > 0) {
	hpg += d__[icoi] * gn[icoi];
    }
    if (icos > 0) {
	hpg += d__[icos] * gn[icos];
    }

    icoi = 0;
    icos = 0;
    if (hpd != 0. || hpg != 0.) {
	goto L360;
    }

 
 
    tmaxp = 0.;
    ico1 = 0;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = d__[i__]) < 0.) {
	    goto L310;
	} else if (d__1 == 0) {
	    goto L350;
	} else {
	    goto L320;
	}
L310:
	t2 = (binf[i__] - x[i__]) / d__[i__];
	goto L330;
L320:
	t2 = (bsup[i__] - x[i__]) / d__[i__];
L330:
	if (t2 <= 0.) {
	    goto L350;
	}
	if (tmaxp == 0.) {
	    tmaxp = t2;
	}
	if (tmaxp > t2) {
	    goto L350;
	}
	tmaxp = t2;
	ico1 = i__;
L350:
	;
    }
    if (*t < tmaxp) {
	if (fn <= *f + *amf * *hp * *t) {
	    goto L1010;
	}
	*t /= 10.;
	s_copy(var2, "d  ", 3L, 3L);
	goto L800;
    }
    icos = ico1;
    icoi = 0;
    if (d__[ico1] < 0.) {
	icoi = ico1;
	icos = 0;
    }

 
    if (*imp >= 3) {
	io___3089.ciunit = *io;
	s_wsfe(&io___3089);
	do_fio(&c__1, (char *)&tmaxp, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    *t = tmaxp;
    if (fn < *f + *amf * *hp * tmaxp) {
	*indrl = 8;
	goto L1010;
    }
    hpg = d__[ico1] * gn[ico1];
    if (fn < *f && hpg < 0.) {
	*indrl = 8;
	goto L1010;
    }
L360:

 

    a = *f + *amf * *hp * *t;
    if (fn > a) {
 
 

	td = *t;
	t1 = *t - ta1;
	h1 = (fn - fa1) / t1;
	ftd = fn;
	hptd = hpg;
	ta = tg;
	hpn = hptd;
	hpa = hptg;
	fa = ftg;
    } else {
	if (hpd >= *amd * *hp) {
	    goto L1010;
	}
 
	tg = *t;
	t1 = *t - ta1;
	h1 = (fn - fa1) / t1;
	ftg = fn;
	hptg = hpd;
	ta = td;
	hpn = hptg;
	hpa = hptd;
	fa = ftd;
	if (td == 0.) {
	    goto L700;
	}
	a1 = (d__1 = hptd / *hp, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (a1 > cofder && ftd > *f && hptg > *hp * (float).99) {
	    hpta1 = *hp;
	    fa1 = *f;
	    ta1 = 0.;
	    goto L700;
	}
    }
    a1 = (d__1 = hpn / *hp, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    if (tg != 0. || fn <= *f || a1 <= cofder || hpn < 0.) {
	if (td <= *tproj) {
	    goto L600;
	}
	goto L500;
    }

 

 

    ta1 = *t;
    fa1 = fn;
    div = *hp - hptd;
    text = *t / 10.;
    if ((( div ) >= 0 ? ( div ) : -( div ))  > *zero) {
	text = *t * (*hp / div);
    }
    if (text > *tproj) {
	text = *t / 10.;
    }
 
    d__1 = text, d__2 = *t / (extrp * extra);
    text = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    d__1 = text, d__2 = *t * eps1;
    *t = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    ttsup = *t * 1.5;
    extrp = (float)10.;
    if (*tproj > ta1) {
	s_copy(var2, "id ", 3L, 3L);
	goto L800;
    }
    ttmin = *t * .7;
    tmi = *t;
    topt = 0.;
    iproj = 0;
    satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, 
	    &td, &tmi, &icoi, &icos, &iproj);
    s_copy(var2, "id ", 3L, 3L);
    if (topt != 0.) {
	*t = topt;
	s_copy(var2, "ids", 3L, 3L);
    }
    goto L800;

 

L500:
    if (td <= *tproj) {
	goto L600;
    }
    topt = 0.;
    iproj = 1;
    ta1 = *t;
    fa1 = fn;
    ttmin = tg + eps * (td - tg);
    ttsup = td - eps * (td - tg);
    tmi = (td + tg) / 2.;
    satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, 
	    &td, &tmi, &icoi, &icos, &iproj);
    if (topt == 0.) {
	goto L600;
    }
    *t = topt;
    s_copy(var2, "s  ", 3L, 3L);
    if (*t == ttsup || *t == ttmin) {
	s_copy(var2, "sb ", 3L, 3L);
    }
    goto L800;

 

 
L600:
    if (td - tg < *zero * 100.) {
	k = 4;
	goto L1000;
    }

 
    b = 1.;
    p = hpn + hpa - (fn - fa) * 3. / (*t - ta);
    di = p * p - hpn * hpa;
    if (di < 0.) {
	goto L690;
    }
    if (*t - ta < 0.) {
	b = -1.;
    }
    div = hpn + p + b * sqrt(di);
    if ((( div ) >= 0 ? ( div ) : -( div ))  <= *zero) {
	goto L690;
    }
    r__ = hpn / div;
    topt = *t - r__ * (*t - ta);
    if (topt < tg || topt > td) {
	goto L690;
    }

 
    e = epst * (td - tg);
    s_copy(var2, "ic ", 3L, 3L);
    if (topt > td - e) {
	topt = td - e;
	s_copy(var2, "icb", 3L, 3L);
    }
    if (topt < tg + e) {
	topt = tg + e;
	s_copy(var2, "icb", 3L, 3L);
    }
    ta1 = *t;
    fa1 = fn;
    *t = topt;
    goto L800;
L690:
    ta1 = *t;
    fa1 = fn;
    *t = (tg + td) * .5;
    s_copy(var2, "d  ", 3L, 3L);
    goto L800;

 

L700:
    if (imax >= 1) {
	k = 2;
	goto L1000;
    }
    text = *t * 10.;
    difhp = hptg - hpta1;
    if (difhp > *zero) {
	text = (*amd * *hp / 3. - hptg) * ((tg - ta1) / difhp) + tg;
	if (td != 0. && text >= td) {
	    goto L600;
	}
 
 
	d__1 = text, d__2 = extra * extrp * *t;
	text = (( d__1 ) <= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
	d__1 = text, d__2 = *t * 2.5;
	text = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    } else {
	text = extra * extrp * *t;
    }
    ta1 = *t;
    fa1 = fn;
    hpta1 = hpn;
    extrp = (float)10.;
    if (text >= *tmax / 2.) {
	text = *tmax;
	imax = 1;
    }
    if (*t < *tproj && text > *tproj) {
 
	d__1 = *tproj, d__2 = *t * 2.5;
	*t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	icoi = 0;
	icos = icop;
	if (d__[icop] < 0.) {
	    icoi = icop;
	    icos = 0;
	}
	s_copy(var2, "es ", 3L, 3L);
	goto L800;
    }
 
    d__1 = text * 1.5;
    ttsup = (( d__1 ) <= ( *tmax ) ? ( d__1 ) : ( *tmax )) ;
    if (ttsup < *tproj) {
	goto L785;
    }
    ttmin = *t * 2;
    iproj = 0;
    tmi = text;
    topt = 0.;
    satur_(n, &x[1], &binf[1], &bsup[1], &d__[1], &ttmin, &ttsup, &topt, &tg, 
	    &td, &tmi, &icoi, &icos, &iproj);
    if (topt > 0.) {
	*t = topt;
	s_copy(var2, "es ", 3L, 3L);
	goto L800;
    }
L785:
    *t = text;
    s_copy(var2, "e  ", 3L, 3L);
L800:
    f11 = fn - *f;
    if (*imp >= 3 && indic > 0) {
	io___3114.ciunit = *io;
	s_wsfe(&io___3114);
	do_fio(&c__1, var2, 3L);
	do_fio(&c__1, (char *)&ta1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&f11, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&hpn, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&h1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&t1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 
    if ((d__1 = ta1 - *t, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) >= *zero * 100.) {
	goto L200;
    }
    k = 4;
 
L1000:
    if (indic < 0) {
	*indrl = 13;
	if (tg == 0.) {
	    *indrl = indic - 1000;
	}
	fn = ftg;
	hpn = hptg;
	*t = tg;
	goto L1010;
    }
    if (fn <= ftg) {
	*indrl = k;
	*t = tg;
	goto L1010;
    }
    if (tg == 0.) {
	*indrl = -k;
	goto L1010;
    }
    *indrl = k + 10;
    *t = tg;
    fn = ftg;
    hpn = hptg;

 
L1010:
    *f = fn;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x[i__] += *t * d__[i__];
    }
    proj_(n, &binf[1], &bsup[1], &x[1]);
    if (icos > 0) {
	x[icos] = bsup[icos];
    }
    if (icoi > 0) {
	x[icoi] = binf[icoi];
    }

    if (*indrl < 0) {
	++(*nap);
	indic = 4;
	(*simul)(&indic, n, &x[1], f, &gn[1], &izs[1], &rzs[1], &dzs[1]);
    }

    t1 = *t - ta1;
    if (t1 == 0.) {
	t1 = (float)1.;
    }
    h1 = (fn - fa1) / t1;
    *hp = hpd;
    f0 = *f - f0;
    if (*imp >= 3) {
	io___3115.ciunit = *io;
	s_wsfe(&io___3115);
	do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&f0, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&hpd, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&h1, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&t1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    return 0;
}  

  int satur_(n, x, binf, bsup, d__, ttmin, ttsup, topt, tg, td,
	 tmi, icoi, icos, iproj)
integer *n;
doublereal *x, *binf, *bsup, *d__, *ttmin, *ttsup, *topt, *tg, *td, *tmi;
integer *icoi, *icos, *iproj;
{
     
    integer i__1;
    doublereal d__1;

     
    static doublereal e;
    static integer i__;
    static doublereal ep, tb;
    static integer inf;


 
 
 

 
 

 

 

 
 
 
 
 
 
 
 
 
 
 


     
    --d__;
    --bsup;
    --binf;
    --x;

     
    *icoi = 0;
    *icos = 0;
    ep = *tmi;

 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	inf = 0;
 
	if ((d__1 = d__[i__]) < 0.) {
	    goto L61;
	} else if (d__1 == 0) {
	    goto L70;
	} else {
	    goto L62;
	}
L61:
	tb = (binf[i__] - x[i__]) / d__[i__];
	inf = 1;
	goto L63;
L62:
	tb = (bsup[i__] - x[i__]) / d__[i__];
L63:
	if (tb > *ttsup || tb < *ttmin) {
 
	    if (*iproj == 0 || tb < *tg || tb > *td) {
		goto L70;
	    }
	    tb = (( tb ) >= ( *ttmin ) ? ( tb ) : ( *ttmin )) ;
	    tb = (( tb ) <= ( *ttsup ) ? ( tb ) : ( *ttsup )) ;
	    inf = 2;
	}
 
	e = (d__1 = tb - *tmi, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	if (e >= ep) {
	    goto L70;
	}
	*topt = tb;
	ep = e;
 
	*icoi = 0;
	*icos = 0;
	if (inf == 0) {
	    *icos = i__;
	}
	if (inf == 1) {
	    *icoi = i__;
	}
L70:
	;
    }
    return 0;
}  

  int shanph_(diag, n, nt, np, y, s, ys, scal, index, io, imp)
doublereal *diag;
integer *n, *nt, *np;
doublereal *y, *s, *ys, *scal;
integer *index, *io, *imp;
{
     
    static char fmt_1203[] = "(\002 gcbd. facteur d echelle=\002,d15.7)";

     
    integer y_dim1, y_offset, s_dim1, s_offset, i__1;
    doublereal d__1;

     
    integer s_wsfe(), do_fio(), e_wsfe();

     
    static integer i__;
    static doublereal cof;
    static integer inp;

     
    static cilist io___3124 = { 0, 0, 0, fmt_1203, 0 };


 
 
 

     
    --diag;
    --index;
    --ys;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;

     
    inp = index[*np];
    cof = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = y[inp + i__ * y_dim1];
	cof += d__1 * d__1 / diag[i__];
    }
    cof /= ys[inp];
    if (*imp > 3) {
	io___3124.ciunit = *io;
	s_wsfe(&io___3124);
	do_fio(&c__1, (char *)&cof, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	diag[i__] = cof * diag[i__];
    }
    *scal = (float)0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	*scal += diag[i__];
    }
    *scal = *n / *scal;
    return 0;
}  

  int strang_(prosca, n, m, depl, jmin, jmax, precon, alpha, 
	ybar, sbar, izs, rzs, dzs)
  int (*prosca) ();
integer *n, *m;
doublereal *depl;
integer *jmin, *jmax;
doublereal *precon, *alpha, *ybar, *sbar;
integer *izs;
real *rzs;
doublereal *dzs;
{
     
    integer ybar_dim1, ybar_offset, sbar_dim1, sbar_offset, i__1, i__2;

     
    static integer jfin, i__, j;
    static doublereal r__;
    static integer jp;
    static doublereal ps;

 

 
 

 
 

 
 
 

 
 

 

 
 

 

 

 

 


 


     
    --depl;
    sbar_dim1 = *n;
    sbar_offset = sbar_dim1 + 1;
    sbar -= sbar_offset;
    ybar_dim1 = *n;
    ybar_offset = ybar_dim1 + 1;
    ybar -= ybar_offset;
    --alpha;
    --izs;
    --rzs;
    --dzs;

     
    jfin = *jmax;
    if (jfin < *jmin) {
	jfin = *jmax + *m;
    }

 

    i__1 = *jmin;
    for (j = jfin; j >= i__1; --j) {
	jp = j;
	if (jp > *m) {
	    jp -= *m;
	}
	(*prosca)(n, &depl[1], &sbar[jp * sbar_dim1 + 1], &ps, &izs[1], &rzs[
		1], &dzs[1]);
	alpha[jp] = ps;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    depl[i__] -= ps * ybar[i__ + jp * ybar_dim1];
 
	}
 
    }

 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	depl[i__] *= *precon;
 
    }

 

    i__1 = jfin;
    for (j = *jmin; j <= i__1; ++j) {
	jp = j;
	if (jp > *m) {
	    jp -= *m;
	}
	(*prosca)(n, &depl[1], &ybar[jp * ybar_dim1 + 1], &ps, &izs[1], &rzs[
		1], &dzs[1]);
	r__ = alpha[jp] - ps;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    depl[i__] += r__ * sbar[i__ + jp * sbar_dim1];
 
	}
 
    }
    return 0;
}  

  int tol03_(q, iq, r__, ir, c__, ic, d__, a, ia, b, ci, cs, x,
	 w, ipvt, n, m, mi, mi1, nmd, io)
doublereal *q;
integer *iq;
doublereal *r__;
integer *ir;
doublereal *c__;
integer *ic;
doublereal *d__, *a;
integer *ia;
doublereal *b, *ci, *cs, *x, *w;
integer *ipvt, *n, *m, *mi, *mi1, *nmd, *io;
{
     
    integer q_dim1, q_offset, r_dim1, r_offset, c_dim1, c_offset, a_dim1, 
	    a_offset, i__1;
    doublereal d__1;

     
    double pow_dd();

     
    extern doublereal ddot_();
    static integer i__, j;
    static doublereal s;
    extern   int anrs01_(), dmmul_();
    static integer m1;
    static doublereal dj;
    extern doublereal dlamch_();
    static integer ind;
    static doublereal eps;
    extern   int dadd_();


 

 

 

 

 

 

 

 

 

 

 

 


 
 

 

 

 

 

 

 

 
 

 


 

 

 

 

 


 

 

 

 

 

 
 

 

 


 
 
 

 
 


     
    q_dim1 = *iq;
    q_offset = q_dim1 + 1;
    q -= q_offset;
    r_dim1 = *ir;
    r_offset = r_dim1 + 1;
    r__ -= r_offset;
    c_dim1 = *ic;
    c_offset = c_dim1 + 1;
    c__ -= c_offset;
    --d__;
    a_dim1 = *ia;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    --b;
    --ci;
    --cs;
    --x;
    --w;
    --ipvt;

     
    d__1 = dlamch_("p", 1L);
    eps = pow_dd(&d__1, &c_b5779);
    ind = 0;
    m1 = *m + 1;
    i__1 = *mi1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	j = ipvt[i__];
	dj = d__[j];
	s = dj - ddot_(n, &c__[j * c_dim1 + 1], &c__1, &x[1], &c__1);
	w[i__] = s;
	if (ind == 0) {
	    s = (( s ) >= 0 ? ( s ) : -( s ))  / ((( dj ) >= 0 ? ( dj ) : -( dj ))  + 1);
	    if (s > eps) {
		ind = 1;
	    }
	}
 
    }
    i__1 = *m;
    for (i__ = *mi1 + 1; i__ <= i__1; ++i__) {
	j = ipvt[i__];
	if (j < 0) {
	    j = -j;
	    dj = ci[j];
	    s = x[j] - dj;
	} else if (j <= *n) {
	    dj = cs[j];
	    s = dj - x[j];
	} else if (j <= *nmd) {
	    j = *mi + j - *n;
	    dj = d__[j];
	    s = dj - ddot_(n, &c__[j * c_dim1 + 1], &c__1, &x[1], &c__1);
	} else {
	    j -= *nmd;
	    dj = b[j];
	    s = dj - ddot_(n, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1);
	}
	w[i__] = s;
	if (ind == 0) {
	    s = (( s ) >= 0 ? ( s ) : -( s ))  / ((( dj ) >= 0 ? ( dj ) : -( dj ))  + 1.);
	    if (s > eps) {
		ind = 1;
	    }
	}
 
    }
    if (ind == 0) {
	return 0;
    }
    anrs01_(&r__[r_offset], ir, m, &w[1], &w[1], &ind, io);
    dmmul_(&q[q_offset], iq, &w[1], m, &w[m1], n, n, m, &c__1);
    dadd_(n, &w[m1], &c__1, &x[1], &c__1);
}  

  int zgcbd_(simul, n, binf, bsup, x, f, g, zero, napmax, 
	itmax, indgc, ibloc, nfac, imp, io, epsx, epsf, epsg, dir, df0, diag, 
	x2, izs, rzs, dzs, y, s, z__, ys, zs, nt, index, wk1, wk2, alg, ialg, 
	nomf, nomf_len)
  int (*simul) ();
integer *n;
doublereal *binf, *bsup, *x, *f, *g, *zero;
integer *napmax, *itmax, *indgc, *ibloc, *nfac, *imp, *io;
doublereal *epsx, *epsf, *epsg, *dir, *df0, *diag, *x2;
integer *izs;
real *rzs;
doublereal *dzs, *y, *s, *z__, *ys, *zs;
integer *nt, *index;
doublereal *wk1, *wk2, *alg;
integer *ialg;
char *nomf;
ftnlen nomf_len;
{
     
    static char fmt_10000[] = "(\002 dans gcbd. algorithme utilise: \002)";
    static char fmt_10001[] = "(\002        emploi correction de powell \002)"
	    ;
    static char fmt_10002[] = "(\002  mise a jour de diag par la methode bfgs\002)";
    static char fmt_10003[] = "(\002  mise a echelle de diag par methode de shanno-phua\002)";
    static char fmt_10004[] = "(\002  mise a echelle de diag seulement a la 2e iter\002)";
    static char fmt_10005[] = "(\002      memorisation pour choix iteration \002)";
    static char fmt_10006[] = "(\002      memorisation par variable\002)";
    static char fmt_10007[] = "(\002      relachememt de variables a toutes les iteration\002)";
    static char fmt_10008[] = "(\002      relachement de vars si decroissance g_norme\002)";
    static char fmt_10009[] = "(\002      relachement de vars si dec f % iter_init du cycle\002)";
    static char fmt_10010[] = "(\002      relachement de vars si dec f % dec du cycle\002)";
    static char fmt_10011[] = "(\002      choix de vars a relacher par bertsekas modifiee\002)";
    static char fmt_10012[] = "(\002      choix de dir descente par methode de gradient\002)";
    static char fmt_10013[] = "(\002      choix de dir descente par methode qn\002)";
    static char fmt_10014[] = "(\002      choix de dir descente par qn sans memoire.nt depl\002)";
    static char fmt_10015[] = "(\002      choix de dir descente par qn -mem,redem,sans acc.\002)";
    static char fmt_10016[] = "(\002     choix de dir descente par qn -mem,redem,avec acc.\002)";
    static char fmt_10017[] = "(\002      redem si relachement de vars\002)";
    static char fmt_10018[] = "(\002      redem si dec f % dec iter_init du cycle\002)";
    static char fmt_10019[] = "(\002      redem si dec f % dec totale du cycle.\002)";
    static char fmt_10020[] = "(\002    redem si diminution du gradient des var libres d un\002,\002facteur\002,d11.4)";
    static char fmt_123[] = "(\002 gcbd : retour avec indgc=\002,i8)";
    static char fmt_1210[] = "(/\002 dans gcbd  iter=\002,i3,\002  f=\002,d15.7)";
    static char fmt_1270[] = "(\002 gcbd. emploi correction powell (y,s)=\002,d11.4)";
    static char fmt_1280[] = "(\002 erreur relative correction powell =\002,d11.4)";
    static char fmt_1000[] = "(\002   redemarrage. icycl=\002,i5)";
    static char fmt_1712[] = "(\002 gcbd : restauration dir ; fp,zero\002,2d11.4)";
    static char fmt_750[] = "(\002 retour mlibd indrl=\002,i6,\002 pas= \002,d11.4,\002 f= \002,d11.4)";
    static char fmt_777[] = "(\002 i=\002,i2,\002 xgd \002,3f11.4)";
    static char fmt_755[] = "(\002 gcbd max appels simul\002)";
    static char fmt_1805[] = "(\002 gcbd. retour apres convergence sur x\002)"
	    ;
    static char fmt_860[] = "(\002 gcbd. epsg,difg=\002,2d11.4,\002  epsf,diff=\002,2d11.4,\002  nap=\002,i3)";
    static char fmt_1910[] = "(\002 arret impose par la recherche lineaire. cf notice rlbd\002,/,\002 indicateur de rlbd=\002,i6)";
    static char fmt_950[] = "(\002 f,norme grad,nap,iter,indgc=\002,2e11.4,3i6)";
    static char fmt_2001[] = "(1x,a6,2e11.4,2i5,f6.2,i5)";

     
    integer y_dim1, y_offset, s_dim1, s_offset, z_dim1, z_offset, i__1;
    doublereal d__1, d__2;

     
    integer s_wsfe(), e_wsfe(), do_fio();
    double sqrt();

     
    static doublereal diff, difg, scal;
    static integer ired;
    extern   int rlbd_();
    static doublereal diri;
    static integer nred, izag;
    extern doublereal ddot_();
    static integer napm;
    static doublereal teta;
    extern   int majz_();
    static integer iter, irit;
    extern   int proj_();
    static doublereal tmax, ceps0;
    static integer izag1, napm1;
    static doublereal teta1, znog0;
    static integer i__;
    extern   int bfgsd_();
    static doublereal t, condm, param;
    static integer icycl, napav, indrl;
    static doublereal tetaq;
    extern   int dcopy_();
    static doublereal epsxi, tproj;
    static integer indgc1;
    static doublereal dfred1, param1, dfrit1, aa;
    static integer lb, nb;
    static doublereal fn, difred;
    static integer np;
    static doublereal xi, sy, epsgcp;
    extern   int shanph_();
    static integer indsim;
    extern   int majysa_();
    static doublereal znglib, difrit;
    extern doublereal rednor_();
    static doublereal zngred;
    extern   int relvar_();
    static integer iresul;
    static doublereal zngrit, ys1, amd, amf;
    extern   int gcp_();
    static integer ind;
    static doublereal dfp;
    static integer nap, ifp, irl, inp;
    static doublereal bss, zng, zrl;
    static integer imp1;
    static doublereal eps0, bss2;

     
    static cilist io___3138 = { 0, 0, 0, fmt_10000, 0 };
    static cilist io___3139 = { 0, 0, 0, fmt_10001, 0 };
    static cilist io___3140 = { 0, 0, 0, fmt_10002, 0 };
    static cilist io___3141 = { 0, 0, 0, fmt_10003, 0 };
    static cilist io___3142 = { 0, 0, 0, fmt_10004, 0 };
    static cilist io___3143 = { 0, 0, 0, fmt_10005, 0 };
    static cilist io___3144 = { 0, 0, 0, fmt_10006, 0 };
    static cilist io___3145 = { 0, 0, 0, fmt_10007, 0 };
    static cilist io___3146 = { 0, 0, 0, fmt_10008, 0 };
    static cilist io___3147 = { 0, 0, 0, fmt_10009, 0 };
    static cilist io___3148 = { 0, 0, 0, fmt_10010, 0 };
    static cilist io___3149 = { 0, 0, 0, fmt_10011, 0 };
    static cilist io___3150 = { 0, 0, 0, fmt_10012, 0 };
    static cilist io___3151 = { 0, 0, 0, fmt_10013, 0 };
    static cilist io___3152 = { 0, 0, 0, fmt_10014, 0 };
    static cilist io___3153 = { 0, 0, 0, fmt_10015, 0 };
    static cilist io___3154 = { 0, 0, 0, fmt_10016, 0 };
    static cilist io___3155 = { 0, 0, 0, fmt_10017, 0 };
    static cilist io___3156 = { 0, 0, 0, fmt_10018, 0 };
    static cilist io___3157 = { 0, 0, 0, fmt_10019, 0 };
    static cilist io___3158 = { 0, 0, 0, fmt_10020, 0 };
    static cilist io___3167 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3186 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3188 = { 0, 0, 0, fmt_1210, 0 };
    static cilist io___3194 = { 0, 0, 0, fmt_1270, 0 };
    static cilist io___3198 = { 0, 0, 0, fmt_1280, 0 };
    static cilist io___3208 = { 0, 0, 0, fmt_1000, 0 };
    static cilist io___3215 = { 0, 0, 0, fmt_1712, 0 };
    static cilist io___3224 = { 0, 0, 0, fmt_750, 0 };
    static cilist io___3225 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3226 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3227 = { 0, 0, 0, fmt_777, 0 };
    static cilist io___3228 = { 0, 0, 0, fmt_755, 0 };
    static cilist io___3229 = { 0, 0, 0, fmt_1805, 0 };
    static cilist io___3231 = { 0, 0, 0, fmt_860, 0 };
    static cilist io___3233 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3234 = { 0, 0, 0, fmt_1910, 0 };
    static cilist io___3235 = { 0, 0, 0, fmt_950, 0 };
    static cilist io___3237 = { 0, 0, 0, fmt_2001, 0 };




     
    --wk2;
    --wk1;
    --x2;
    --diag;
    --dir;
    --epsx;
    --ibloc;
    --g;
    --x;
    --bsup;
    --binf;
    --izs;
    --rzs;
    --dzs;
    --index;
    --zs;
    --ys;
    z_dim1 = *nt;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;
    s_dim1 = *nt;
    s_offset = s_dim1 + 1;
    s -= s_offset;
    y_dim1 = *nt;
    y_offset = y_dim1 + 1;
    y -= y_offset;
    --alg;
    --ialg;

     
    if (*imp >= 4) {
	io___3138.ciunit = *io;
	s_wsfe(&io___3138);
	e_wsfe();
	if (ialg[1] == 1) {
	    io___3139.ciunit = *io;
	    s_wsfe(&io___3139);
	    e_wsfe();
	}
	if (ialg[2] == 1) {
	    io___3140.ciunit = *io;
	    s_wsfe(&io___3140);
	    e_wsfe();
	}
	if (ialg[3] == 1) {
	    io___3141.ciunit = *io;
	    s_wsfe(&io___3141);
	    e_wsfe();
	}
	if (ialg[3] == 2) {
	    io___3142.ciunit = *io;
	    s_wsfe(&io___3142);
	    e_wsfe();
	}
	if (ialg[4] == 1) {
	    io___3143.ciunit = *io;
	    s_wsfe(&io___3143);
	    e_wsfe();
	}
	if (ialg[5] == 1) {
	    io___3144.ciunit = *io;
	    s_wsfe(&io___3144);
	    e_wsfe();
	}
	if (ialg[6] == 1) {
	    io___3145.ciunit = *io;
	    s_wsfe(&io___3145);
	    e_wsfe();
	}
	if (ialg[6] == 2) {
	    io___3146.ciunit = *io;
	    s_wsfe(&io___3146);
	    e_wsfe();
	}
	if (ialg[6] == 10) {
	    io___3147.ciunit = *io;
	    s_wsfe(&io___3147);
	    e_wsfe();
	}
	if (ialg[6] == 11) {
	    io___3148.ciunit = *io;
	    s_wsfe(&io___3148);
	    e_wsfe();
	}
	if (ialg[7] == 1) {
	    io___3149.ciunit = *io;
	    s_wsfe(&io___3149);
	    e_wsfe();
	}
	if (ialg[8] == 1) {
	    io___3150.ciunit = *io;
	    s_wsfe(&io___3150);
	    e_wsfe();
	}
	if (ialg[8] == 2) {
	    io___3151.ciunit = *io;
	    s_wsfe(&io___3151);
	    e_wsfe();
	}
	if (ialg[8] == 3) {
	    io___3152.ciunit = *io;
	    s_wsfe(&io___3152);
	    e_wsfe();
	}
	if (ialg[8] == 4) {
	    io___3153.ciunit = *io;
	    s_wsfe(&io___3153);
	    e_wsfe();
	}
	if (ialg[8] == 5) {
	    io___3154.ciunit = *io;
	    s_wsfe(&io___3154);
	    e_wsfe();
	}
	if (ialg[9] == 2) {
	    io___3155.ciunit = *io;
	    s_wsfe(&io___3155);
	    e_wsfe();
	}
	if (ialg[9] == 10) {
	    io___3156.ciunit = *io;
	    s_wsfe(&io___3156);
	    e_wsfe();
	}
	if (ialg[9] == 11) {
	    io___3157.ciunit = *io;
	    s_wsfe(&io___3157);
	    e_wsfe();
	}
	if (ialg[9] == 12) {
	    io___3158.ciunit = *io;
	    s_wsfe(&io___3158);
	    do_fio(&c__1, (char *)&alg[9], (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
    }

 
 
 
 

    epsgcp = 1e-5;
    indsim = 4;
    indrl = 1;
    irl = 0;
    irl = 0;
    nred = 1;
    icycl = 1;

    iresul = 1;
    proj_(n, &binf[1], &bsup[1], &x[1]);
    indsim = 4;
    (*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
    ++nap;
    if (indsim > 0) {
	goto L99;
    }
    *indgc = -1;
    if (indsim == 0) {
	*indgc = 0;
    }
    if (*imp > 0) {
	io___3167.ciunit = *io;
	s_wsfe(&io___3167);
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    goto L900;
L99:
    ceps0 = 20.;
    eps0 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	eps0 += epsx[i__];
    }
    eps0 = ceps0 * eps0 / *n;

 
    znog0 = rednor_(n, &binf[1], &bsup[1], &x[1], &epsx[1], &g[1]);
    zng = znog0;
    zngrit = znog0;
    zngred = znog0;

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	ibloc[i__] = 0;
    }
    izag = 3;
    izag1 = izag;
    nap = 0;
    iter = 0;
    scal = 1.;
    *nfac = *n;
    np = 0;
    lb = 1;
    nb = 2;
    if (ialg[8] == 3) {
	nb = 1;
    }
    i__1 = *nt;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	index[i__] = i__;
    }
    tetaq = alg[9];
    condm = alg[2];
    param = alg[1];
    indgc1 = *indgc;
 

    if (*indgc == 1 || *indgc >= 100) {
	goto L150;
    }
    if (*indgc == 2) {
	goto L180;
    }
    *indgc = -13;
    if (*imp > 0) {
	io___3186.ciunit = *io;
	s_wsfe(&io___3186);
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    goto L900;

L150:
 
 
 
 
    sy = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = g[i__] * epsx[i__];
	sy += d__1 * d__1;
    }
    sy /= *df0 * 2.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = epsx[i__];
	diag[i__] = (sy + *zero) / (d__1 * d__1 + *zero);
    }
L180:


 
L200:
    ++iter;
    *indgc = 1;
    if (iter > *itmax) {
	*indgc = 5;
	goto L900;
    }
 
    if (*imp >= 2) {
	io___3188.ciunit = *io;
	s_wsfe(&io___3188);
	do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (iter == 1) {
	irit = 1;
	goto L301;
    }

    majysa_(n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], &lb, &g[1], &x[1],
	     &wk2[1], &wk1[1], &index[1], &ialg[1], &nb);
    inp = index[np];


 
    if (ialg[1] != 1) {
	goto L290;
    }
    param1 = (float)1. - param;
    bss = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = s[inp + i__ * s_dim1];
	bss += diag[i__] * (d__1 * d__1);
    }
    bss2 = param * bss;
    if (ys[inp] > bss2) {
	goto L290;
    }
    if (*imp > 2) {
	io___3194.ciunit = *io;
	s_wsfe(&io___3194);
	do_fio(&c__1, (char *)&ys[inp], (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    teta = param1 * bss / (bss - ys[inp]);
    teta1 = 1. - teta;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	y[inp + i__ * y_dim1] = teta * y[inp + i__ * y_dim1] + teta1 * diag[
		i__] * s[inp + i__ * s_dim1];
    }
    ys[inp] = bss2;
 
    ys1 = ddot_(n, &s[inp + s_dim1], &c__1, &y[inp + y_dim1], &c__1);
    ys1 = (d__1 = bss2 - ys1, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / bss2;
    if (*imp > 2) {
	io___3198.ciunit = *io;
	s_wsfe(&io___3198);
	do_fio(&c__1, (char *)&ys1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 
L290:
    if (ialg[2] == 1) {
	bfgsd_(&diag[1], n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], &
		condm, &param, zero, &index[1]);
    }

    if (ialg[3] == 1 || ialg[3] == 2 && iter == 2) {
	shanph_(&diag[1], n, nt, &np, &y[y_offset], &s[s_offset], &ys[1], &
		scal, &index[1], io, imp);
    }

    majz_(n, &np, nt, &y[y_offset], &s[s_offset], &z__[z_offset], &ys[1], &zs[
	    1], &diag[1], &index[1]);

 
 
 
 
    irit = 0;
    if (ialg[6] == 1) {
	irit = 1;
    }
    if (ialg[6] == 2 && znglib <= alg[6] * zngrit) {
	irit = 1;
    }
    if (ialg[6] == 10 && diff <= dfrit1 * alg[6]) {
	irit = 1;
    }
    if (ialg[6] == 11 && diff <= difrit * alg[6]) {
	irit = 1;
    }
    if (irit == 1) {
	++nred;
    }
 
    imp1 = *imp;
L301:
    if (ialg[7] == 1) {
	relvar_(&ind, n, &x[1], &binf[1], &bsup[1], &x2[1], &g[1], &diag[1], 
		imp, io, &ibloc[1], &izag, &iter, nfac, &irit);
    }


 
    if (np == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    dir[i__] = -g[i__] / diag[i__];
 
	}
    } else {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    dir[i__] = -scal * g[i__];
 
	}
	gcp_(n, &index[1], &ibloc[1], &np, nt, &y[y_offset], &s[s_offset], &
		z__[z_offset], &ys[1], &zs[1], &diag[1], &g[1], &dir[1], &wk1[
		1], &wk2[1], &epsgcp);
    }

 

    if (ialg[8] == 4 || ialg[8] == 5) {
	ired = 0;
	if (ialg[9] == 2 && ind == 1) {
	    ired = 1;
	}
	if (ialg[9] == 10 && diff < dfred1 * tetaq) {
	    ired = 1;
	}
	if (ialg[9] == 11 && diff < difred * tetaq) {
	    ired = 1;
	}
	if (ialg[9] == 12 && znglib <= tetaq * zngred) {
	    ired = 1;
	}
	if (ired == 1) {
	    ++icycl;
	    np = 0;
	    lb = 1;
	    if (*imp > 2) {
		io___3208.ciunit = *io;
		s_wsfe(&io___3208);
		do_fio(&c__1, (char *)&icycl, (ftnlen)sizeof(integer));
		e_wsfe();
	    }
	}
    }

 
    if (ialg[6] == 1) {
	goto L640;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	if (ibloc[i__] > 0) {
	    dir[i__] = 0.;
	}
    }
L640:

 
 
    dcopy_(n, &x[1], &c__1, &wk1[1], &c__1);
    dcopy_(n, &g[1], &c__1, &wk2[1], &c__1);
 
    ifp = 0;
    fn = *f;
    znog0 = zng;
L702:
    dfp = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	epsxi = epsx[i__];
	xi = x[i__];
	diri = dir[i__];
	if (xi - binf[i__] <= epsxi && diri < 0.) {
	    dir[i__] = 0.;
	}
 
	if (bsup[i__] - xi <= epsxi && diri > 0.) {
	    dir[i__] = 0.;
	}
    }
    dfp = ddot_(n, &g[1], &c__1, &dir[1], &c__1);
    if (-dfp > 0.) {
	goto L715;
    }
    if (ifp == 1) {
	*indgc = 6;
	goto L900;
    }
 
    if (*imp >= 3) {
	io___3215.ciunit = *io;
	s_wsfe(&io___3215);
	do_fio(&c__1, (char *)&dfp, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*zero), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dir[i__] = -scal * g[i__];
    }
    ifp = 1;
    goto L702;
L715:
 
    t = diff * -2. / dfp;
    if (iter == 1) {
	t = *df0 * -2. / dfp;
    }
    tmax = 1e10;
    t = (( t ) <= ( tmax ) ? ( t ) : ( tmax )) ;
 
    d__1 = t, d__2 = *zero * 1e10;
    t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
    napm = 15;
    napm1 = nap + napm;
    if (napm1 > *napmax) {
	napm1 = *napmax;
    }
    napav = nap;
    amd = .7;
    amf = .1;

    rlbd_(&indrl, n, simul, &x[1], &binf[1], &bsup[1], f, &dfp, &t, &tmax, &
	    dir[1], &g[1], &tproj, &amd, &amf, imp, io, zero, &nap, &napm1, &
	    x2[1], &izs[1], &rzs[1], &dzs[1]);
    if (*imp > 2) {
	io___3224.ciunit = *io;
	s_wsfe(&io___3224);
	do_fio(&c__1, (char *)&indrl, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&t, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (nap - napav >= 5) {
	++irl;
    }
    if (indrl >= 10) {
	indsim = 4;
	++nap;
	(*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
	if (indsim <= 0) {
	    *indgc = -3;
	    if (indsim == 0) {
		*indgc = 0;
	    }
	    if (*imp > 0) {
		io___3225.ciunit = *io;
		s_wsfe(&io___3225);
		do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
		e_wsfe();
	    }
	    goto L900;
	}
    }
    if (indrl <= 0) {
	*indgc = 10;
	if (indrl == 0) {
	    *indgc = 0;
	}
	if (indrl == -3) {
	    *indgc = 13;
	}
	if (indrl == -4) {
	    *indgc = 12;
	}
	if (indrl <= -1000) {
	    *indgc = 11;
	}
	if (*imp > 0) {
	    io___3226.ciunit = *io;
	    s_wsfe(&io___3226);
	    do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	goto L900;
    }
    if (*imp >= 5) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
 
	    if (*imp > 2) {
		io___3227.ciunit = *io;
		s_wsfe(&io___3227);
		do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
		do_fio(&c__1, (char *)&g[i__], (ftnlen)sizeof(doublereal));
		do_fio(&c__1, (char *)&dir[i__], (ftnlen)sizeof(doublereal));
		e_wsfe();
	    }
	}
    }

    if (nap < *napmax) {
	goto L758;
    }
    if (*imp > 0) {
	io___3228.ciunit = *io;
	s_wsfe(&io___3228);
	e_wsfe();
    }
    *indgc = 4;
    goto L900;
L758:

 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = x[i__] - wk1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > epsx[i__]) {
	    goto L806;
	}
 
    }
    if (*imp > 0) {
	io___3229.ciunit = *io;
	s_wsfe(&io___3229);
	e_wsfe();
    }
    *indgc = 3;
    goto L900;
 
L806:
    difg = rednor_(n, &binf[1], &bsup[1], &x[1], &epsx[1], &g[1]);
    diff = fn - *f;
    if (*imp >= 2) {
	io___3231.ciunit = *io;
	s_wsfe(&io___3231);
	do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*epsf), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer));
	e_wsfe();
    }

    if (diff <= *epsf) {
	*indgc = 2;
	goto L900;
    }
    if (difg <= *epsg) {
	*indgc = 1;
	goto L900;
    }

 
    if (irit == 1) {
	difrit = diff;
	dfrit1 = diff;
    } else {
	difrit += diff;
    }
    if (ired == 1) {
	difred = diff;
	dfred1 = diff;
    } else {
	difred += diff;
    }

    znglib = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (ibloc[i__] > 0) {
	    goto L884;
	}
	aa = g[i__];
	if (x[i__] - binf[i__] <= epsx[i__]) {
	    aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ;
	}
	if (bsup[i__] - x[i__] <= epsx[i__]) {
	    aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ;
	}
 
	d__1 = aa;
	znglib += d__1 * d__1;
L884:
	;
    }
    znglib = sqrt(znglib);
    if (ired == 1) {
	zngred = znglib;
    }
    if (irit == 1) {
	zngrit = znglib;
    }
    goto L200;

 
L900:
    if (indrl == 0) {
	*indgc = 0;
    }
    if (*indgc == 1 && indrl <= 0) {
	*indgc = indrl;
    }
    if (*imp > 0) {
	io___3233.ciunit = *io;
	s_wsfe(&io___3233);
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*imp >= 1 && (doublereal) indrl <= *zero) {
	io___3234.ciunit = *io;
	s_wsfe(&io___3234);
	do_fio(&c__1, (char *)&indrl, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*imp >= 1) {
	io___3235.ciunit = *io;
	s_wsfe(&io___3235);
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*indgc), (ftnlen)sizeof(integer));
	e_wsfe();
    }

 
    if (indgc1 < 100) {
	return 0;
    }
    zrl = (float)0.;
    if (iter > 0) {
	zrl = (doublereal) nap / (doublereal) iter;
    }
 
    io___3237.ciunit = *io;
    s_wsfe(&io___3237);
    do_fio(&c__1, nomf, 6L);
    do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&zrl, (ftnlen)sizeof(doublereal));
    do_fio(&c__1, (char *)&irl, (ftnlen)sizeof(integer));
    e_wsfe();
}  

  int zqnbd_(indqn, simul, dh, n, binf, bsup, x, f, g, zero, 
	napmax, itmax, indic, izig, nfac, imp, io, epsx, epsf, epsg, x1, x2, 
	g1, dir, df0, ig, in, irel, izag, iact, epsrel, ieps1, izs, rzs, dzs)
integer *indqn;
  int (*simul) ();
doublereal *dh;
integer *n;
doublereal *binf, *bsup, *x, *f, *g, *zero;
integer *napmax, *itmax, *indic, *izig, *nfac, *imp, *io;
doublereal *epsx, *epsf, *epsg, *x1, *x2, *g1, *dir, *df0;
integer *ig, *in, *irel, *izag, *iact;
doublereal *epsrel;
integer *ieps1, *izs;
real *rzs;
doublereal *dzs;
{
     
    static char fmt_1020[] = "(\002 qnbd :  izag,ig,in,irel,iact,epsrel=\002,5i3,f11.4)";
    static char fmt_110[] = "(\002 test sur gradient pour sortie ib\002)";
    static char fmt_111[] = "(\002 test sur nombre de defactorisations pour sortie ib\002)";
    static char fmt_112[] = "(\002 memorisation de variables izag=\002,i3)";
    static char fmt_114[] = "(\002 methode de minimisations incompletes ; epsrel=\002,d11.4)";
    static char fmt_116[] = "(\002 blocage des variables dans ib\002)";
    static char fmt_118[] = "(\002 parametre eps1 nul\002)";
    static char fmt_119[] = "(\002 parametre eps1 grand\002)";
    static char fmt_120[] = "(\002 parametre eps1=eps(x) calcule avec cscal1=\002,d11.4)";
    static char fmt_105[] = "(\002 qnbd  : valeur non admissible de indqn  \002,i5)";
    static char fmt_123[] = "(\002 qnbd : indqn=\002,i8)";
    static char fmt_1202[] = "(\002 qnbd : maximum d iterations atteint\002)";
    static char fmt_1210[] = "(/\002 qnbd : iter=\002,i3,\002  f=\002,d15.7)";
    static char fmt_1203[] = "(\002 qnbd : facteur d echelle=\002,d11.4)";
    static char fmt_1272[] = "(\002 qnbd : pb (bs,s) negatif=\002,d11.4)";
    static char fmt_1270[] = "(\002 qnbd : emploi truc powell (y,s)=\002,d11.4)";
    static char fmt_282[] = "(\002 qnbd : pb dans appel majour\002)";
    static char fmt_322[] = "(\002 qnbd : val de eps1 servant a partitionner les variables\002,d11.4)";
    static char fmt_1320[] = "(\002 qnbd : redemarrage ; difg0,epsrel,difg1=\002,3d11.4)";
    static char fmt_336[] = "(\002 defactorisation de \002,i3)";
    static char fmt_333[] = "(\002 qnbd : pb dans ajour. mode=\002,i3)";
    static char fmt_339[] = "(\002 on factorise l indice \002,i3)";
    static char fmt_350[] = "(\002 qnbd : nbre fact\002,i3,\002 defact\002,i3,\002 total var factorisees\002,i3)";
    static char fmt_650[] = "(\002 qnbd : pb num dans mult par inverse\002)";
    static char fmt_1705[] = "(\002 qnbd : arret fpn non negatif=\002,d11.4)";
    static char fmt_777[] = "(\002 i=\002,i2,\002 xgd \002,3f11.4)";
    static char fmt_755[] = "(\002 qnbd : retour cause max appels simul\002,i9)";
    static char fmt_1805[] = "(\002 qnbd : retour apres convergence de x\002)"
	    ;
    static char fmt_860[] = "(\002 qnbd : epsg,difg=\002,2d11.4,\002  epsf,diff=\002,2d11.4,\002  nap=\002,i3)";
    static char fmt_1865[] = "(\002 qnbd : retour cause decroissance f trop petite=\002,d11.4)";
    static char fmt_1900[] = "(\002 qnbd : retour cause gradient projete petit=\002,d11.4)";

     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    integer s_wsfe(), do_fio(), e_wsfe();
    double sqrt();

     
    static integer ifac;
    static doublereal diff, difg, scal;
    extern   int rlbd_();
    static integer mode, napm;
    static doublereal teta;
    static integer iter, irit;
    extern   int proj_();
    static doublereal tmax;
    static integer nfac1;
    static doublereal difg0, difg1;
    static integer n2fac;
    static doublereal scal1;
    static integer napm1;
    static doublereal teta1, zsig1;
    static integer idfac, i__, j, k;
    static doublereal t;
    static integer nnfac;
    static doublereal v, y, epsmc;
    static integer indrl, iconv;
    extern   int ajour_();
    static doublereal d1, tiers, d2;
    static integer i1;
    static doublereal tproj;
    static integer n1, n3;
    static doublereal t1, cscal1, aa, dd, bi;
    static integer ic, ii, ij;
    static doublereal fn, bs, ep;
    static integer ip, mk, ir;
    extern   int calmaj_();
    static doublereal gr;
    static integer np, indsim, nm1;
    static doublereal amd, amf;
    static integer ndh, nap, ifp;
    static doublereal sig, fpn;
    static integer nip;
    static doublereal cof1, cof2, sig1, eps0, eps1;

     
    static cilist io___3238 = { 0, 0, 0, fmt_1020, 0 };
    static cilist io___3239 = { 0, 0, 0, fmt_110, 0 };
    static cilist io___3240 = { 0, 0, 0, fmt_111, 0 };
    static cilist io___3241 = { 0, 0, 0, fmt_112, 0 };
    static cilist io___3242 = { 0, 0, 0, fmt_114, 0 };
    static cilist io___3243 = { 0, 0, 0, fmt_116, 0 };
    static cilist io___3244 = { 0, 0, 0, fmt_118, 0 };
    static cilist io___3245 = { 0, 0, 0, fmt_119, 0 };
    static cilist io___3247 = { 0, 0, 0, fmt_120, 0 };
    static cilist io___3253 = { 0, 0, 0, fmt_105, 0 };
    static cilist io___3254 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3259 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3263 = { 0, 0, 0, fmt_1202, 0 };
    static cilist io___3264 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3265 = { 0, 0, 0, fmt_1210, 0 };
    static cilist io___3267 = { 0, 0, 0, fmt_1203, 0 };
    static cilist io___3281 = { 0, 0, 0, fmt_1272, 0 };
    static cilist io___3282 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3283 = { 0, 0, 0, fmt_1270, 0 };
    static cilist io___3291 = { 0, 0, 0, fmt_282, 0 };
    static cilist io___3292 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3295 = { 0, 0, 0, fmt_322, 0 };
    static cilist io___3302 = { 0, 0, 0, fmt_1320, 0 };
    static cilist io___3312 = { 0, 0, 0, fmt_336, 0 };
    static cilist io___3313 = { 0, 0, 0, fmt_333, 0 };
    static cilist io___3314 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3315 = { 0, 0, 0, fmt_339, 0 };
    static cilist io___3316 = { 0, 0, 0, fmt_333, 0 };
    static cilist io___3317 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3318 = { 0, 0, 0, fmt_350, 0 };
    static cilist io___3321 = { 0, 0, 0, fmt_650, 0 };
    static cilist io___3322 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3326 = { 0, 0, 0, fmt_1705, 0 };
    static cilist io___3327 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3338 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3339 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3340 = { 0, 0, 0, fmt_777, 0 };
    static cilist io___3341 = { 0, 0, 0, fmt_755, 0 };
    static cilist io___3342 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3343 = { 0, 0, 0, fmt_1805, 0 };
    static cilist io___3344 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3346 = { 0, 0, 0, fmt_860, 0 };
    static cilist io___3347 = { 0, 0, 0, fmt_1865, 0 };
    static cilist io___3348 = { 0, 0, 0, fmt_123, 0 };
    static cilist io___3349 = { 0, 0, 0, fmt_1900, 0 };
    static cilist io___3350 = { 0, 0, 0, fmt_123, 0 };




     
    --dh;
    --dir;
    --g1;
    --x2;
    --x1;
    --epsx;
    --izig;
    --indic;
    --g;
    --x;
    --bsup;
    --binf;
    --izs;
    --rzs;
    --dzs;

     
    if (*imp < 4) {
	goto L3;
    }
    io___3238.ciunit = *io;
    s_wsfe(&io___3238);
    do_fio(&c__1, (char *)&(*izag), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*ig), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*in), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*irel), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*iact), (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal));
    e_wsfe();

    if (*ig == 1) {
	io___3239.ciunit = *io;
	s_wsfe(&io___3239);
	e_wsfe();
    }
    if (*in == 1) {
	io___3240.ciunit = *io;
	s_wsfe(&io___3240);
	e_wsfe();
    }
    if (*izag != 0) {
	io___3241.ciunit = *io;
	s_wsfe(&io___3241);
	do_fio(&c__1, (char *)&(*izag), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (*irel == 1) {
	io___3242.ciunit = *io;
	s_wsfe(&io___3242);
	do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*iact == 1) {
	io___3243.ciunit = *io;
	s_wsfe(&io___3243);
	e_wsfe();
    }
    if (*ieps1 == 1) {
	io___3244.ciunit = *io;
	s_wsfe(&io___3244);
	e_wsfe();
    }
    if (*ieps1 == 2) {
	io___3245.ciunit = *io;
	s_wsfe(&io___3245);
	e_wsfe();
    }

 
    cscal1 = 1e8;
    if (*ieps1 == 2) {
	io___3247.ciunit = *io;
	s_wsfe(&io___3247);
	do_fio(&c__1, (char *)&cscal1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
L3:

    difg0 = 1.;
    difg1 = 0.;

 
    eps0 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	izig[i__] = 0;
 
	eps0 += epsx[i__];
    }
    eps0 = eps0 * (float)10. / *n;

 
 

    proj_(n, &binf[1], &bsup[1], &x[1]);
    ndh = *n * (*n + 1) / 2;
    if (*indqn == 1) {
	goto L10;
    }
    if (*indqn == 2) {
	goto L30;
    }
 
    if (*imp > 0) {
	io___3253.ciunit = *io;
	s_wsfe(&io___3253);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    *indqn = -105;
    if (*imp > 0) {
	io___3254.ciunit = *io;
	s_wsfe(&io___3254);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L10:
 
 
    *nfac = 0;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	indic[i__] = i__;
    }
    i__1 = ndh;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	dh[i__] = 0.;
    }
L30:

 

 
    iter = 0;
    scal = 1.;
    nap = 1;
    indsim = 4;
    if (*indqn == 1) {
	(*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
    }
    if (indsim <= 0) {
	*indqn = -1;
	if (indsim == 0) {
	    *indqn = 0;
	}
	if (*imp > 0) {
	    io___3259.ciunit = *io;
	    s_wsfe(&io___3259);
	    do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	return 0;
    }
    if (*indqn != 1) {
	goto L200;
    }
 
 
 
 
    cof1 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = g[i__] * epsx[i__];
	cof1 += d__1 * d__1;
    }
    cof1 /= *df0 * 2.;
    i1 = -(*n);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i1 + *n + 2 - i__;
 
 
	d__1 = epsx[i__];
	dh[i1] = (cof1 + *zero) / (d__1 * d__1 + *zero);
    }
    iconv = 0;
L200:
    ++iter;
    if (iter <= *itmax) {
	goto L202;
    }
    if (*imp > 0) {
	io___3263.ciunit = *io;
	s_wsfe(&io___3263);
	e_wsfe();
    }
    *indqn = 5;
    if (*imp > 0) {
	io___3264.ciunit = *io;
	s_wsfe(&io___3264);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L202:
    if (*imp >= 2) {
	io___3265.ciunit = *io;
	s_wsfe(&io___3265);
	do_fio(&c__1, (char *)&iter, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*f), (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
    if (iter == 1) {
	goto L300;
    }
    cof1 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x1[i__] = x[i__] - x1[i__];
	g1[i__] = g[i__] - g1[i__];
 
	cof1 += x1[i__] * g1[i__];
    }
    if (cof1 <= *zero) {
	goto L250;
    }
    if (iter > 2 || *indqn != 1) {
	goto L250;
    }
 
 
    cof2 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
 
	d__1 = g1[i__];
	cof2 += d__1 * d__1;
    }
    cof2 /= cof1;
    if (*imp > 3) {
	io___3267.ciunit = *io;
	s_wsfe(&io___3267);
	do_fio(&c__1, (char *)&cof2, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    dh[1] = cof2;
    i1 = 1;
    i__1 = *nfac;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i1 + *n + 1 - i__;
 
	dh[i1] = cof2;
    }

 
 
    scal = 1. / cof2;
L250:

 
 
 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = indic[i__];
	x2[i1] = g1[i__];
 
	dir[i1] = x1[i__];
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	g1[i__] = x2[i__];
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = indic[i__];
 
	x2[i1] = x1[i__];
    }
 
 
    if (*nfac == 0) {
	goto L2312;
    }
    if (*nfac > 1) {
	goto L2300;
    }
    dir[1] *= dh[1];
    goto L2312;
L2300:
    np = *nfac + 1;
    ii = 1;
    n1 = *nfac - 1;
    i__1 = n1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	y = dir[i__];
	if (dh[ii] == 0.) {
	    goto L2302;
	}
	ij = ii;
	ip = i__ + 1;
	i__2 = *nfac;
	for (j = ip; j <= i__2; ++j) {
	    ++ij;
 
	    y += dir[j] * dh[ij];
	}
L2302:
	dir[i__] = y * dh[ii];
 
	ii = ii + np - i__;
    }
    dir[*nfac] *= dh[ii];
    i__1 = n1;
    for (k = 1; k <= i__1; ++k) {
	i__ = *nfac - k;
	ii = ii - np + i__;
	if (dir[i__] == 0.) {
	    goto L2311;
	}
	ip = i__ + 1;
	ij = ii;
	y = dir[i__];
	i__2 = *nfac;
	for (j = ip; j <= i__2; ++j) {
	    ++ij;
 
	    dir[j] += dh[ij] * dir[i__];
	}
L2311:
	;
    }
L2312:
    nfac1 = *nfac + 1;
    n2fac = *nfac * nfac1 / 2;
    nnfac = *n - *nfac;
    k = n2fac;
    if (*nfac == *n) {
	goto L268;
    }
    i__1 = *n;
    for (i__ = nfac1; i__ <= i__1; ++i__) {
 
	dir[i__] = 0.;
    }
    if (*nfac == 0) {
	goto L265;
    }
    i__1 = *nfac;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *n;
	for (j = nfac1; j <= i__2; ++j) {
	    ++k;
	    if (x2[j] == (float)0.) {
		goto L260;
	    }
	    dir[i__] += dh[k] * x2[j];
L260:
	    ;
	}
    }
 
    k = n2fac;
    i__2 = *nfac;
    for (j = 1; j <= i__2; ++j) {
	i__1 = *n;
	for (i__ = nfac1; i__ <= i__1; ++i__) {
	    ++k;
	    dir[i__] += dh[k] * x2[j];
 
	}
    }
L265:
    k = n2fac + *nfac * nnfac;
    i__1 = *n;
    for (j = nfac1; j <= i__1; ++j) {
	i__2 = *n;
	for (i__ = j; i__ <= i__2; ++i__) {
	    ++k;
	    if (x2[j] == (float)0.) {
		goto L266;
	    }
	    dir[i__] += dh[k] * x2[j];
L266:
	    ;
	}
    }
    if (*nfac == *n - 1) {
	goto L268;
    }
    nm1 = *n - 1;
    k = n2fac + *nfac * nnfac;
    i__2 = nm1;
    for (i__ = nfac1; i__ <= i__2; ++i__) {
	++k;
	i1 = i__ + 1;
	i__1 = *n;
	for (j = i1; j <= i__1; ++j) {
	    ++k;
	    if (x2[j] == (float)0.) {
		goto L267;
	    }
	    dir[i__] += dh[k] * x2[j];
L267:
	    ;
	}
    }
 
 
L268:
    sig1 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	sig1 += dir[i__] * x2[i__];
    }
    if (sig1 > 0.) {
	goto L272;
    }
    if (*imp > 2) {
	io___3281.ciunit = *io;
	s_wsfe(&io___3281);
	do_fio(&c__1, (char *)&sig1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

 
    *indqn = 8;
    if (iter == 1) {
	*indqn = -5;
    }
    if (*imp > 0) {
	io___3282.ciunit = *io;
	s_wsfe(&io___3282);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L272:
    sig1 = -1. / sig1;
 
    if (cof1 > *zero) {
	goto L277;
    }
    if (*imp > 2) {
	io___3283.ciunit = *io;
	s_wsfe(&io___3283);
	do_fio(&c__1, (char *)&cof1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    teta = -1. / sig1;
    teta = teta * (float).8 / (teta - cof1);
    teta1 = 1. - teta;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	g1[i__] = teta * g1[i__] + teta1 * dir[i__];
    }
    cof1 = (float)-.2 / sig1;
L277:

 
    sig = 1. / cof1;
    zsig1 = 1. / sig1;
    mk = 0;
    ir = *nfac;
    epsmc = 1e-9;
    calmaj_(&dh[1], n, &g1[1], &sig, &x2[1], &ir, &mk, &epsmc, nfac);
    if (ir != *nfac) {
	goto L280;
    }
    calmaj_(&dh[1], n, &dir[1], &sig1, &x2[1], &ir, &mk, &epsmc, nfac);
    if (ir != *nfac) {
	goto L280;
    }
    goto L300;
L280:
    if (*imp > 0) {
	io___3291.ciunit = *io;
	s_wsfe(&io___3291);
	e_wsfe();
    }
    *indqn = 8;
    if (iter == 1) {
	*indqn = -5;
    }
    if (*imp > 0) {
	io___3292.ciunit = *io;
	s_wsfe(&io___3292);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L300:

 

 

    scal1 = scal;
    if (*ieps1 == 1) {
	scal1 = 0.;
    }
    if (*ieps1 == 2) {
	scal1 = scal * cscal1;
    }
 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	x1[i__] = x[i__] - scal1 * (d__1 = g[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * g[i__];
    }
    proj_(n, &binf[1], &bsup[1], &x1[1]);
    eps1 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	eps1 += (d__1 = x1[i__] - x[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    }
    eps1 = (( eps0 ) <= ( eps1 ) ? ( eps0 ) : ( eps1 )) ;
    if (*ieps1 == 1) {
	eps1 = 0.;
    }
    if (*ieps1 == 2) {
	eps1 *= 1e4;
    }
    if (*imp > 3) {
	io___3295.ciunit = *io;
	s_wsfe(&io___3295);
	do_fio(&c__1, (char *)&eps1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
 
    ifac = 0;
    idfac = 0;
    k = 0;


    gr = 0.;
    if (*ig == 1) {
	gr = difg * (float).2 / *n;
    }
    n3 = *n;
    if (*in == 1) {
	n3 = *n / 10;
    }
 
    irit = 0;
    if (difg1 <= *epsrel * difg0) {
	irit = 1;
    }
    if (*irel == 0 || iter == 1) {
	irit = 1;
    }
    if (irit * *irel > 0 && *imp > 3) {
	io___3302.ciunit = *io;
	s_wsfe(&io___3302);
	do_fio(&c__1, (char *)&difg0, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*epsrel), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&difg1, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

    tiers = .33333333333333331;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	--izig[k];
	if (izig[k] <= 0) {
	    izig[k] = 0;
	}
	bi = binf[k];
	bs = bsup[k];
	ic = indic[k];
	d1 = x[k] - bi;
	d2 = bs - x[k];
	dd = (bs - bi) * tiers;
	ep = (( eps1 ) <= ( dd ) ? ( eps1 ) : ( dd )) ;
	if (d1 > ep) {
	    goto L324;
	}
	if (g[k] > (float)0.) {
	    goto L330;
	}
	goto L335;
L324:
	if (d2 > ep) {
	    goto L335;
	}
	if (g[k] > (float)0.) {
	    goto L335;
	}
	goto L330;
 
L330:
	if (ic > *nfac) {
	    goto L340;
	}
	++idfac;
	mode = -1;
	if (*imp >= 4) {
	    io___3312.ciunit = *io;
	    s_wsfe(&io___3312);
	    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	izig[k] += *izag;
	ajour_(&mode, n, &k, nfac, &dh[1], &x2[1], &indic[1]);
	if (mode == 0) {
	    goto L340;
	}
	if (*imp > 0) {
	    io___3313.ciunit = *io;
	    s_wsfe(&io___3313);
	    do_fio(&c__1, (char *)&mode, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*indqn = 8;
	if (iter == 1) {
	    *indqn = -5;
	}
	if (*imp > 0) {
	    io___3314.ciunit = *io;
	    s_wsfe(&io___3314);
	    do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	return 0;
 
L335:
	if (irit == 0) {
	    goto L340;
	}
	if (ic <= *nfac) {
	    goto L340;
	}
	if (izig[k] >= 1) {
	    goto L340;
	}
	mode = 1;
	if (ifac >= n3 && iter > 1) {
	    goto L340;
	}
	if ((d__1 = g[k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= gr) {
	    goto L340;
	}
	++ifac;
	if (*imp >= 4) {
	    io___3315.ciunit = *io;
	    s_wsfe(&io___3315);
	    do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	ajour_(&mode, n, &k, nfac, &dh[1], &x2[1], &indic[1]);
	if (mode == 0) {
	    goto L340;
	}
	if (*imp > 0) {
	    io___3316.ciunit = *io;
	    s_wsfe(&io___3316);
	    do_fio(&c__1, (char *)&mode, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	*indqn = 8;
	if (iter == 1) {
	    *indqn = -5;
	}
	if (*imp > 0) {
	    io___3317.ciunit = *io;
	    s_wsfe(&io___3317);
	    do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	return 0;
L340:
	;
    }
    if (*imp >= 2) {
	io___3318.ciunit = *io;
	s_wsfe(&io___3318);
	do_fio(&c__1, (char *)&ifac, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&idfac, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&(*nfac), (ftnlen)sizeof(integer));
	e_wsfe();
    }

 
    if (iconv == 1) {
	return 0;
    }

 
 
 
    ir = *nfac;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = indic[i__];
 
	x2[i1] = g[i__];
    }
 
    if (ir < *nfac) {
	goto L412;
    }
    if (*nfac > 1) {
	goto L400;
    }
    x2[1] /= dh[1];
    goto L412;
L400:
    i__1 = *nfac;
    for (i__ = 2; i__ <= i__1; ++i__) {
	ij = i__;
	i1 = i__ - 1;
	v = x2[i__];
	i__2 = i1;
	for (j = 1; j <= i__2; ++j) {
	    v -= dh[ij] * x2[j];
 
	    ij = ij + *nfac - j;
	}
	x2[i__] = v;
 
	x2[i__] = v;
    }
    x2[*nfac] /= dh[ij];
    np = *nfac + 1;
    i__1 = *nfac;
    for (nip = 2; nip <= i__1; ++nip) {
	i__ = np - nip;
	ii = ij - nip;
	v = x2[i__] / dh[ii];
	ip = i__ + 1;
	ij = ii;
	i__2 = *nfac;
	for (j = ip; j <= i__2; ++j) {
	    ++ii;
 
	    v -= dh[ii] * x2[j];
	}
 
	x2[i__] = v;
    }
L412:
    if (ir == *nfac) {
	goto L660;
    }
    if (*imp > 0) {
	io___3321.ciunit = *io;
	s_wsfe(&io___3321);
	e_wsfe();
    }
    *indqn = 7;
    if (iter == 1) {
	*indqn = -6;
    }
    if (*imp > 0) {
	io___3322.ciunit = *io;
	s_wsfe(&io___3322);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L660:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = indic[i__];
	dir[i__] = -g[i__] * scal;
 
	if (i1 <= *nfac) {
	    dir[i__] = -x2[i1];
	}
    }

 
    if (*iact != 1) {
	goto L675;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (izig[i__] > 0) {
	    dir[i__] = (float)0.;
	}
	if (indic[i__] > *nfac) {
	    dir[i__] = 0.;
	}
 
    }
L675:

 
 
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	g1[i__] = g[i__];
 
	x1[i__] = x[i__];
    }
 
    ifp = 0;
    fn = *f;
L709:
    fpn = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (x[i__] - binf[i__] <= epsx[i__] && dir[i__] < (float)0.) {
	    dir[i__] = 0.;
	}
	if (bsup[i__] - x[i__] <= epsx[i__] && dir[i__] > (float)0.) {
	    dir[i__] = 0.;
	}
 
	fpn += g[i__] * dir[i__];
    }
    if (fpn > 0.) {
	if (ifp == 1) {
	    if (*imp > 0) {
		io___3326.ciunit = *io;
		s_wsfe(&io___3326);
		do_fio(&c__1, (char *)&fpn, (ftnlen)sizeof(doublereal));
		e_wsfe();
	    }
	    *indqn = 6;
	    if (iter == 1) {
		*indqn = -3;
	    }
	    if (*imp > 0) {
		io___3327.ciunit = *io;
		s_wsfe(&io___3327);
		do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
		e_wsfe();
	    }
	    return 0;
	} else {
	    ifp = 1;
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {
 
		if (izig[i__] > 0) {
		    dir[i__] = -scal * g[i__];
		}
	    }
	    irit = 1;
	    goto L709;
	}
    }
 
    t1 = t;
    if (iter == 1) {
	diff = *df0;
    }
    t = diff * -2. / fpn;
    if (t > .3 && t < 3.) {
	t = 1.;
    }
    if (eps1 < eps0) {
	t = 1.;
    }
    if (*indqn == 2) {
	t = 1.;
    }
    if (iter > 1 && t1 > .01 && t1 < 100.) {
	t = 1.;
    }
    tmax = 1e10;
    t = (( t ) <= ( tmax ) ? ( t ) : ( tmax )) ;
 
    d__1 = t, d__2 = *zero * (float)10.;
    t = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
 
    amd = (float).7;
    amf = (float).1;
    napm = 15;
    napm1 = nap + napm;
    if (napm1 > *napmax) {
	napm1 = *napmax;
    }
    rlbd_(&indrl, n, simul, &x[1], &binf[1], &bsup[1], &fn, &fpn, &t, &tmax, &
	    dir[1], &g[1], &tproj, &amd, &amf, imp, io, zero, &nap, &napm1, &
	    x2[1], &izs[1], &rzs[1], &dzs[1]);
    if (indrl >= 10) {
	indsim = 4;
	++nap;
	(*simul)(&indsim, n, &x[1], f, &g[1], &izs[1], &rzs[1], &dzs[1]);
	if (indsim <= 0) {
	    *indqn = -3;
	    if (indsim == 0) {
		*indqn = 0;
	    }
	    if (*imp > 0) {
		io___3338.ciunit = *io;
		s_wsfe(&io___3338);
		do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
		e_wsfe();
	    }
	    return 0;
	}
    }
    if (indrl <= 0) {
	*indqn = 10;
	if (indrl == 0) {
	    *indqn = 0;
	}
	if (indrl == -3) {
	    *indqn = 13;
	}
	if (indrl == -4) {
	    *indqn = 12;
	}
	if (indrl <= -1000) {
	    *indqn = 11;
	}
	if (*imp > 0) {
	    io___3339.ciunit = *io;
	    s_wsfe(&io___3339);
	    do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	return 0;
    }

 
    if (*imp < 6) {
	goto L778;
    }
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	io___3340.ciunit = *io;
	s_wsfe(&io___3340);
	do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&x[i__], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&g[i__], (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&dir[i__], (ftnlen)sizeof(doublereal));
	e_wsfe();
    }

L778:
    if (nap < *napmax) {
	goto L758;
    }
    *f = fn;
    if (*imp > 0) {
	io___3341.ciunit = *io;
	s_wsfe(&io___3341);
	do_fio(&c__1, (char *)&(*napmax), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    *indqn = 4;
    if (*imp > 0) {
	io___3342.ciunit = *io;
	s_wsfe(&io___3342);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L758:
 

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if ((d__1 = x[i__] - x1[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) > epsx[i__]) {
	    goto L806;
	}
 
    }
    *f = fn;
    if (*imp > 0) {
	io___3343.ciunit = *io;
	s_wsfe(&io___3343);
	e_wsfe();
    }
    *indqn = 3;
    if (*imp > 0) {
	io___3344.ciunit = *io;
	s_wsfe(&io___3344);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
L806:
    difg = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	aa = g[i__];
	if (x[i__] - binf[i__] <= epsx[i__]) {
	    aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ;
	}
	if (bsup[i__] - x[i__] <= epsx[i__]) {
	    aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ;
	}
 
 
	d__1 = aa;
	difg += d__1 * d__1;
    }
    difg1 = 0.;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (indic[i__] > *nfac) {
	    goto L820;
	}
	aa = g[i__];
	if (x[i__] - binf[i__] <= epsx[i__]) {
	    aa = (( 0. ) <= ( aa ) ? ( 0. ) : ( aa )) ;
	}
	if (bsup[i__] - x[i__] <= epsx[i__]) {
	    aa = (( 0. ) >= ( aa ) ? ( 0. ) : ( aa )) ;
	}
 
	d__1 = aa;
	difg1 += d__1 * d__1;
L820:
	;
    }
    difg1 = sqrt(difg1);
    difg = sqrt(difg);
    difg /= sqrt((real) (*n));
    diff = (d__1 = *f - fn, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    *df0 = -diff;
    if (irit == 1) {
	difg0 = difg1;
    }
    *f = fn;
    if (*imp >= 2) {
	io___3346.ciunit = *io;
	s_wsfe(&io___3346);
	do_fio(&c__1, (char *)&(*epsg), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&(*epsf), (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal));
	do_fio(&c__1, (char *)&nap, (ftnlen)sizeof(integer));
	e_wsfe();
    }
    if (diff < *epsf) {
	*indqn = 2;
	if (*imp > 0) {
	    io___3347.ciunit = *io;
	    s_wsfe(&io___3347);
	    do_fio(&c__1, (char *)&diff, (ftnlen)sizeof(doublereal));
	    e_wsfe();
	}
	if (*imp > 0) {
	    io___3348.ciunit = *io;
	    s_wsfe(&io___3348);
	    do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	    e_wsfe();
	}
	return 0;
    }
    if (difg > *epsg) {
	goto L200;
    }
    *indqn = 1;
    if (*imp > 0) {
	io___3349.ciunit = *io;
	s_wsfe(&io___3349);
	do_fio(&c__1, (char *)&difg, (ftnlen)sizeof(doublereal));
	e_wsfe();
    }
    if (*imp > 0) {
	io___3350.ciunit = *io;
	s_wsfe(&io___3350);
	do_fio(&c__1, (char *)&(*indqn), (ftnlen)sizeof(integer));
	e_wsfe();
    }
    return 0;
}  

doublereal zthz_(h__, ih, z__, iz, n, i1, i2)
doublereal *h__;
integer *ih;
doublereal *z__;
integer *iz, *n, *i1, *i2;
{
     
    integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2;
    doublereal ret_val;

     
    extern doublereal ddot_();
    static integer j;
    static doublereal s;
    static integer jj;


 

 

 

 

 

 

 

 

 

 

 

 

 


 
 
 

 

 

 

 

 

 

 

 

 


 

 
 
 

 
 


     
    h_dim1 = *ih;
    h_offset = h_dim1 + 1;
    h__ -= h_offset;
    z_dim1 = *iz;
    z_offset = z_dim1 + 1;
    z__ -= z_offset;

     
    ret_val = 0.;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	jj = j + 1;
	s = ddot_(&j, &h__[j + h_dim1], ih, &z__[*i2 * z_dim1 + 1], &c__1);
	i__2 = *n - j;
	s += ddot_(&i__2, &h__[jj + j * h_dim1], &c__1, &z__[jj + *i2 * 
		z_dim1], &c__1);
	ret_val += s * z__[j + *i1 * z_dim1];
 
    }
    return ret_val;
}  

  int bezout_(a, da, b, db, f, df, v, dv, ip)
doublereal *a;
integer *da;
doublereal *b;
integer *db;
doublereal *f;
integer *df;
doublereal *v;
integer *dv, *ip;
{
     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    double sqrt();

     
    static doublereal fact;
    extern   int dset_();
    static doublereal c__[2];
    static integer i__, k, n;
    extern   int dscal_();
    static doublereal x[2];
    extern doublereal dasum_();
    extern   int dcopy_();
    static integer k1, k2, l1, l2, na;
    static doublereal lambda;
    static integer jf[2], nb;
    extern doublereal dlamch_();
    static integer jv[2];
    static doublereal xs[2];
    static integer inc;
    static doublereal eps;

 
 
 
 
 
 
 

 

 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 



     
    dv -= 3;
    --v;
    --df;
    --f;
    --b;
    --a;

     
    eps = dlamch_("p", 1L) * 10.;
    *ip = 0;
    i__1 = *da + 1;
    xs[0] = dasum_(&i__1, &a[1], &c__1);
    i__1 = *db + 1;
    xs[1] = dasum_(&i__1, &b[1], &c__1);
    x[0] = xs[0];
    x[1] = xs[1];
    if (xs[0] == 0.) {
	xs[0] = 1.;
    }
    if (xs[1] == 0.) {
	xs[1] = 1.;
    }
    na = *da + 1;
L10:
    --na;
    if ((d__1 = a[na + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (( xs[0] ) >= 0 ? ( xs[0] ) : -( xs[0] ))  && na >= 1) {
	goto L10;
    }
    nb = *db + 1;
L11:
    --nb;
    if ((d__1 = b[nb + 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (( xs[1] ) >= 0 ? ( xs[1] ) : -( xs[1] ))  && nb >= 1) {
	goto L11;
    }

 

    jf[0] = 1;
    jf[1] = *da + 2;
    i__1 = *da + *db + 2;
    dset_(&i__1, &c_b61, &f[1], &c__1);
    i__1 = na + 1;
    dcopy_(&i__1, &a[1], &c__1, &f[1], &c__1);
    i__1 = na + 1;
    d__1 = 1. / xs[0];
    dscal_(&i__1, &d__1, &f[1], &c__1);
    i__1 = nb + 1;
    dcopy_(&i__1, &b[1], &c__1, &f[jf[1]], &c__1);
    i__1 = nb + 1;
    d__1 = 1. / xs[1];
    dscal_(&i__1, &d__1, &f[jf[1]], &c__1);
    df[1] = na;
    df[2] = nb;

    i__1 = *da + *db + 2 << 1;
    dset_(&i__1, &c_b61, &v[1], &c__1);
    jv[0] = 1;
    jv[1] = *db + 3 + *da;
    inc = *db + 1;
    v[1] = 1.;
    v[jv[1] + inc] = 1.;
    dv[3] = 0;
    dv[4] = 0;
    dv[5] = 0;
    dv[6] = 0;
    c__[0] = 1.;
    c__[1] = 1.;

    k1 = 1;
    k2 = 2;

    if ((( x[0] ) >= 0 ? ( x[0] ) : -( x[0] ))  <= eps * (( x[1] ) >= 0 ? ( x[1] ) : -( x[1] )) ) {
	goto L35;
    }
    if ((( x[1] ) >= 0 ? ( x[1] ) : -( x[1] ))  <= eps * (( x[0] ) >= 0 ? ( x[0] ) : -( x[0] )) ) {
	goto L50;
    }
    x[0] = 1.;
    x[1] = 1.;
 

L20:
    if ((i__1 = df[k1] - df[k2]) < 0) {
	goto L22;
    } else if (i__1 == 0) {
	goto L21;
    } else {
	goto L23;
    }
L21:
    if ((d__1 = f[jf[k1 - 1] + df[k1]], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) < (d__2 = f[jf[k2 - 1] + 
	    df[k2]], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	goto L23;
    }
L22:
    k1 = 3 - k1;
    k2 = 3 - k2;
L23:
 
    fact = c__[0] + c__[1];
    fact *= fact;
 
    if ((d__1 = x[k2 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * fact) {
	df[k2] = 0;
	goto L40;
    }
    n = df[k2] + 1;
    l2 = n + jf[k2 - 1];
L24:
    --l2;
    if (n == 0) {
	goto L30;
    }
    --n;
    if ((d__1 = f[l2], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps * (d__2 = x[k1 - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) )) {
	goto L24;
    }
    df[k2] = n;
 
    lambda = f[jf[k1 - 1] + df[k1]] / f[jf[k2 - 1] + df[k2]];
    n = df[k1] - df[k2];
    fact = sqrt(lambda * lambda + 1.);
 
    l2 = jf[k2 - 1];
    l1 = jf[k1 - 1] + n;
    i__1 = df[k2];
    for (i__ = 0; i__ <= i__1; ++i__) {
	f[l1 + i__] -= lambda * f[l2 + i__];
 
    }
 
    l2 = jv[k2 - 1];
    l1 = jv[k1 - 1] + n;
    c__[k1 - 1] = 0.;
    for (k = 1; k <= 2; ++k) {
	if (dv[k + (k2 << 1)] == 0 && v[l2] == 0.) {
	    goto L27;
	}
	i__1 = dv[k + (k2 << 1)];
	for (i__ = 0; i__ <= i__1; ++i__) {
 
	    v[l1 + i__] -= lambda * v[l2 + i__];
	}
 
	i__1 = dv[k + (k1 << 1)], i__2 = n + dv[k + (k2 << 1)];
	dv[k + (k1 << 1)] = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	i__1 = dv[k + (k1 << 1)] + 1;
	c__[k1 - 1] += dasum_(&i__1, &v[jv[k1 - 1]], &c__1);
L27:
	l1 += inc;
	l2 += inc;
 
    }

    n = df[k1];
    l1 = jf[k1 - 1];
    i__1 = n + 1;
    x[k1 - 1] = dasum_(&i__1, &f[l1], &c__1);
    f[l1 + n] = 0.;
    df[k1] = n - 1;
    goto L20;

 

L30:
    if (k1 == 1) {
	*ip = 1;
    }
    goto L50;
L35:
    *ip = 1;
    goto L50;
L40:
    if (k2 == 1) {
	*ip = 1;
    }

L50:
    l2 = jv[1];
    l1 = jv[0];
    for (k = 1; k <= 2; ++k) {
	i__1 = dv[k + 2] + 1;
	d__1 = 1. / xs[k - 1];
	dscal_(&i__1, &d__1, &v[l1], &c__1);
	i__1 = dv[k + 4] + 1;
	d__1 = 1. / xs[k - 1];
	dscal_(&i__1, &d__1, &v[l2], &c__1);
	l1 += inc;
	l2 += inc;
 
    }

}  

  int bezstp_(p1, n1, p2, n2, a, na, u, nu, l, x, v, w, best, 
	ipb, errr)
doublereal *p1;
integer *n1;
doublereal *p2;
integer *n2;
doublereal *a;
integer *na;
doublereal *u;
integer *nu, *l;
doublereal *x, *v, *w, *best;
integer *ipb;
doublereal *errr;
{
     
    integer a_dim1, a_offset, u_dim1, u_offset, x_dim1, x_offset, v_dim1, 
	    v_offset, i__1, i__2;
    doublereal d__1, d__2;

     
    extern   int ddif_();
    static doublereal fact;
    extern doublereal ddot_();
    static doublereal errd, erri;
    extern   int drot_();
    static doublereal c__;
    static integer k;
    static doublereal s;
    extern   int dscal_();
    static doublereal z__;
    static integer ifree;
    extern   int dcopy_(), dpmul_(), daxpy_();
    static integer n0, m1, m2;
    extern   int dpmul1_();
    static integer nb;
    extern doublereal dlamch_();
    static integer ll;
    static doublereal mm;
    static integer nn, np, iw, nw;
    static doublereal dt0;
    static integer iw1;
    extern   int giv_();
    static doublereal eps;
    static integer iuv, ixy;
    extern   int dadd_();


     
    --p1;
    --p2;
    x_dim1 = *na;
    x_offset = x_dim1 + 1;
    x -= x_offset;
    a_dim1 = *na;
    a_offset = a_dim1 + 1;
    a -= a_offset;
    v_dim1 = *nu;
    v_offset = v_dim1 + 1;
    v -= v_offset;
    u_dim1 = *nu;
    u_offset = u_dim1 + 1;
    u -= u_offset;
    --w;
    --best;
    --ipb;

     
    eps = dlamch_("p", 1L);
    n0 = (( *n1 ) >= ( *n2 ) ? ( *n1 ) : ( *n2 ))  + 1;
 
    i__1 = *n1 - *n2;
    m1 = (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ;
 
    i__1 = *n2 - *n1;
    m2 = (( i__1 ) >= ( 0 ) ? ( i__1 ) : ( 0 )) ;
    ll = *l << 1;
    iuv = 1;
    ixy = iuv + ll;
    iw1 = ixy + ll;
    iw = iw1 + n0;
    ifree = iw + (n0 << 1);

    i__1 = *l;
    for (k = 1; k <= i__1; ++k) {
	giv_(&a[k + (n0 + 1 - k) * a_dim1], &a[k + 1 + (n0 + 1 - k) * a_dim1],
		 &c__, &s);
	drot_(&n0, &a[k + a_dim1], na, &a[k + 1 + a_dim1], na, &c__, &s);
	a[k + 1 + (n0 + 1 - k) * a_dim1] = 0.;
	drot_(&ll, &u[k + u_dim1], nu, &u[k + 1 + u_dim1], nu, &c__, &s);
	if (k == 1 && *l < n0) {
	    i__2 = n0 - 1;
	    dcopy_(&i__2, &a[a_dim1 + 2], na, &x[x_offset], na);
	    dcopy_(&ll, &u[u_dim1 + 2], nu, &v[v_offset], nu);
	}
 
    }

    dcopy_(&ll, &u[*l + u_dim1], nu, &w[iuv], &c__1);
    dcopy_(&ll, &u[*l + 1 + u_dim1], nu, &w[ixy], &c__1);

    if (*l <= (i__1 = *n1 - *n2, (( i__1 ) >= 0 ? ( i__1 ) : -( i__1 )) )) {
	goto L99;
    }
    fact = a[*l + (n0 - *l + 1) * a_dim1];
    if (*l > 1) {
 
	d__1 = w[ixy + (m1 << 1)];
 
	d__2 = w[ixy + 1 + (m2 << 1)];
	mm = d__1 * d__1 + d__2 * d__2;
	z__ = w[iuv + (m1 << 1)] * w[ixy + (m1 << 1)] + w[iuv + 1 + (m2 << 1)]
		 * w[ixy + 1 + (m2 << 1)];
    } else {
 
	d__1 = w[ixy + (m1 << 1)];
	mm = d__1 * d__1;
	z__ = w[iuv + (m1 << 1)] * w[ixy + (m1 << 1)];
    }
    if (mm != 0.) {
 
	z__ = -z__ / mm;
	daxpy_(&ll, &z__, &w[ixy], &c__1, &w[iuv], &c__1);
    }

 

 

    if (fact == 0.) {
	goto L99;
    }
    d__1 = 1. / fact;
    dscal_(&ll, &d__1, &w[iuv], &c__1);
    dt0 = w[ixy + (*l - 1 << 1)] * w[iuv + (*l << 1) - 1] - w[ixy + (*l << 1) 
	    - 1] * w[iuv + (*l - 1 << 1)];
    if (dt0 == 0.) {
	goto L99;
    }
    d__1 = 1. / dt0;
    dscal_(&ll, &d__1, &w[ixy], &c__1);
    dt0 = 1.;

 

 
    i__1 = *l - m1;
    dcopy_(&i__1, &w[ixy + (m1 << 1)], &c__2, &w[iw1], &c_n1);
    i__1 = *l - 1 - m1;
    dpmul1_(&p1[1], n1, &w[iw1], &i__1, &w[iw]);
    nw = *n1 + *l - 1 - m1;
 
    i__1 = *l - m2;
    dcopy_(&i__1, &w[ixy + 1 + (m2 << 1)], &c__2, &w[iw1], &c_n1);
    i__1 = *l - 1 - m2;
    dpmul_(&p2[1], n2, &w[iw1], &i__1, &w[iw], &nw);
    i__1 = nw + 1;
    errd = ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1);
 
    if (*l - 1 - m1 > 0) {
	i__1 = *l - 1 - m1;
	dcopy_(&i__1, &w[iuv + 2 + (m1 << 1)], &c__2, &w[iw1], &c_n1);
	i__1 = *l - 2 - m1;
	dpmul1_(&p1[1], n1, &w[iw1], &i__1, &w[iw]);
	nw = *n1 + *l - 2 - m1;
    } else {
	dpmul1_(&p1[1], n1, &w[iuv + (m1 << 1)], &c__0, &w[iw]);
	nw = *n1;
    }
 
    if (*l - 1 - m2 > 0) {
	i__1 = *l - 1 - m2;
	dcopy_(&i__1, &w[iuv + 3 + (m2 << 1)], &c__2, &w[iw1], &c_n1);
	i__1 = *l - 2 - m2;
	dpmul_(&p2[1], n2, &w[iw1], &i__1, &w[iw], &nw);
    } else {
	dpmul_(&p2[1], n2, &w[iuv + 1 + (m2 << 1)], &c__0, &w[iw], &nw);
    }
 
    np = n0 - *l;
    i__1 = np + 1;
    dcopy_(&i__1, &a[*l + a_dim1], na, &w[iw1], &c__1);
    daxpy_(&np, &z__, &a[*l + 1 + a_dim1], na, &w[iw1], &c__1);
    i__1 = np + 1;
    d__1 = 1. / fact;
    dscal_(&i__1, &d__1, &w[iw1], &c__1);
 
    i__1 = np + 1;
    ddif_(&i__1, &w[iw1], &c__1, &w[iw], &c__1);
    i__1 = nw + 1;
    errd += ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1);

 
 
 
    i__1 = *n1 - np + 1;
    dcopy_(&i__1, &w[ixy + 1 + (m2 << 1)], &c__2, &w[iw], &c_n1);
 
    i__1 = *n1 - np;
    dpmul1_(&w[iw1], &np, &w[iw], &i__1, &w[iw]);
    i__1 = *n1 + 1;
    dadd_(&i__1, &p1[1], &c__1, &w[iw], &c__1);
    i__1 = *n1 + 1;
    erri = ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1);
 
    i__1 = *n2 - np + 1;
    dcopy_(&i__1, &w[ixy + (m1 << 1)], &c__2, &w[iw], &c_n1);
 
    i__1 = *n2 - np;
    dpmul1_(&w[iw1], &np, &w[iw], &i__1, &w[iw]);
 
    i__1 = *n2 + 1;
    ddif_(&i__1, &p2[1], &c__1, &w[iw], &c__1);
    i__1 = *n2 + 1;
    erri += ddot_(&i__1, &w[iw], &c__1, &w[iw], &c__1);
 

    if ((( erri ) >= ( errd ) ? ( erri ) : ( errd ))  < *errr) {
	*errr = (( erri ) >= ( errd ) ? ( erri ) : ( errd )) ;
 
	i__1 = 0, i__2 = n0 - *l;
	nb = (( i__1 ) >= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
	ipb[1] = 1;
 
	i__1 = nb + 1;
	dcopy_(&i__1, &a[*l + a_dim1], na, &best[ipb[1]], &c__1);
	if (*l > 1) {
	    i__1 = nb + 1;
	    daxpy_(&i__1, &z__, &a[*l + 1 + a_dim1], na, &best[ipb[1]], &c__1)
		    ;
	}
	i__1 = nb + 1;
	d__1 = 1. / fact;
	dscal_(&i__1, &d__1, &best[ipb[1]], &c__1);
	ipb[2] = ipb[1] + nb + 1;
	if (*l > 1) {
 
	    i__1 = *n2 - nb;
	    nn = (( i__1 ) >= ( 1 ) ? ( i__1 ) : ( 1 )) ;
	    dcopy_(&nn, &w[iuv + (*l - nn << 1)], &c__2, &best[ipb[2]], &c_n1)
		    ;
	    ipb[3] = ipb[2] + nn;
 
	    i__1 = *n1 - nb;
	    nn = (( i__1 ) >= ( 1 ) ? ( i__1 ) : ( 1 )) ;
	    dcopy_(&nn, &w[iuv + 1 + (*l - nn << 1)], &c__2, &best[ipb[3]], &
		    c_n1);
	    ipb[4] = ipb[3] + nn;
	} else {
	    best[ipb[2]] = w[iuv];
	    ipb[3] = ipb[2] + 1;
	    best[ipb[3]] = w[iuv + 1];
	    ipb[4] = ipb[3] + 1;
	}
	nn = *n2 + 1 - nb;
	dcopy_(&nn, &w[ixy + (*l - nn << 1)], &c__2, &best[ipb[4]], &c_n1);
	ipb[5] = ipb[4] + nn;
	nn = *n1 + 1 - nb;
	dcopy_(&nn, &w[ixy + 1 + (*l - nn << 1)], &c__2, &best[ipb[5]], &c_n1)
		;
	ipb[6] = ipb[5] + nn;
    }

L99:
    return 0;
}  

  int dimin_(lig1, col1, v1, d1, v2, d2, lig2, col2, ligr, 
	colr, ierr)
integer *lig1, *col1, *v1, *d1, *v2, *d2, *lig2, *col2, *ligr, *colr, *ierr;
{
     
    integer i__1;

     
    static integer i__, noo1, noo2;

 

 
 
 
 

 

 

 

 

 

 
 

 
 

 
 
 

 

 
 

 
 
 

 
 


 

 

 
 

 

     
    --v2;
    --v1;

     
    if (*d1 == 0 || *d2 == 0) {
 
	*ierr = 1;
	return 0;
    }

 

 

 

    if (*d1 > 0 && *d2 > 0) {
	goto L5;
    }
    if (*d1 < 0 && *d2 < 0) {
	if (*lig1 != *lig2 || *col1 != *col2) {
 
	    *ierr = 2;
	    return 0;
	}
	*ligr = *lig1;
	*colr = *col1;
	goto L999;
    }

 

 

 

    if (*d1 < 0) {
 
	noo2 = 0;
	i__1 = *d2;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (v2[i__] > noo2) {
		noo2 = v2[i__];
	    }
 
	}
 
	*ligr = (( *lig1 ) >= ( 1 ) ? ( *lig1 ) : ( 1 )) ;
	*colr = (( *col1 ) >= ( noo2 ) ? ( *col1 ) : ( noo2 )) ;
	goto L999;
    }

 

 

 

    if (*d2 < 0) {
 
	noo1 = 0;
	i__1 = *d1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (v1[i__] > noo1) {
		noo1 = v1[i__];
	    }
 
	}
 
	*ligr = (( *lig1 ) >= ( noo1 ) ? ( *lig1 ) : ( noo1 )) ;
	*colr = (( *col1 ) >= ( 1 ) ? ( *col1 ) : ( 1 )) ;
	goto L999;
    }

 

 

 

 
L5:
    if (*d1 != *lig2 || *d2 != *col2) {
	*ierr = 2;
	return 0;
    }
 
    noo1 = 0;
    i__1 = *d1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (v1[i__] > noo1) {
	    noo1 = v1[i__];
	}
 
    }
    noo2 = 0;
    i__1 = *d2;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (v2[i__] > noo2) {
	    noo2 = v2[i__];
	}
 
    }
 
    *ligr = (( *lig1 ) >= ( noo1 ) ? ( *lig1 ) : ( noo1 )) ;
    *colr = (( *col1 ) >= ( noo2 ) ? ( *col1 ) : ( noo2 )) ;
L999:
    *ierr = 0;
    return 0;
}  

 
  int dmdsp_(x, nx, m, n, maxc, mode, ll, lunit, cw, iw, 
	cw_len)
doublereal *x;
integer *nx, *m, *n, *maxc, *mode, *ll, *lunit;
char *cw;
integer *iw;
ftnlen cw_len;
{
     
    static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)";

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3, i__4[2], i__5[4];
    doublereal d__1;
    char ch__1[20], ch__2[27];
    icilist ici__1;

     
      int s_copy();
    integer s_wsfi(), do_fio(), e_wsfi();
    double d_lg10(), pow_di();
      int s_cat();

     
    static integer ldef;
    static doublereal fact;
    static integer imin, imax, ifmt;
    static char form[10*2];
    static doublereal a;
    static integer i__, j, k, l, s, lbloc, nbloc;
    static doublereal a1, a2;
    static integer k1, k2, l1, n1, n2, l0, ib;
    static char dl[1];
    static integer fl, lf, nf;
    extern doublereal dlamch_();
    static integer io, lp;
    extern   int basout_();
    static integer nl1, lgh;
    extern   int fmt_();
    static doublereal eps;
    static char sgn[1];
    static integer typ;

     
    static icilist io___3400 = { 0, form, 0, fmt_130, 10, 1 };


 
 
 
 
 

 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 

 
     
    --iw;
    --x;

     
    eps = dlamch_("p", 1L);
    s_copy(cw, " ", cw_len, 1L);
    s_wsfi(&io___3400);
    do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer));
    i__1 = *maxc - 7;
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    e_wsfi();
    *(unsigned char *)dl = ' ';
    if (*m * *n > 1) {
	*(unsigned char *)dl = '!';
    }

 

    fact = 1.;
    a1 = 0.;
    if (*m * *n == 1) {
	goto L10;
    }
    a2 = (( x[1] ) >= 0 ? ( x[1] ) : -( x[1] )) ;
    l = -(*nx);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	l += *nx;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    a = (d__1 = x[l + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    if (a == 0. || a > dlamch_("o", 1L)) {
		goto L5;
	    }
	    a1 = (( a1 ) >= ( a ) ? ( a1 ) : ( a )) ;
	    a2 = (( a2 ) <= ( a ) ? ( a2 ) : ( a )) ;
L5:
	    ;
	}
    }
    imax = 0;
    imin = 0;
    if (a1 > 0.) {
	imax = (integer) d_lg10(&a1);
    }
    if (a2 > 0.) {
	imin = (integer) d_lg10(&a2);
    }
    if (imax * imin <= 0) {
	goto L10;
    }
    imax = (imax + imin) / 2;
    if ((( imax ) >= 0 ? ( imax ) : -( imax ))  >= *maxc - 2) {
	i__2 = -imax;
	fact = pow_di(&c_b8137, &i__2);
    }
L10:
    eps = a1 * fact * eps;

 
 
 
 
 
 
 

    lbloc = *n;
    lf = lbloc + *n + 1;
    nbloc = 1;
    iw[lbloc + nbloc] = *n;
 
 
 
 

    lp = -(*nx);
    ldef = lf;
    s = 0;
    i__2 = *n;
    for (k = 1; k <= i__2; ++k) {
	iw[k] = 0;
	lp += *nx;
	i__1 = *m;
	for (l = 1; l <= i__1; ++l) {

 
	    a = (d__1 = x[lp + l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) * fact;
 
	    if (a < eps && *mode != 0) {
		a = 0.;
	    }
 
	    typ = 1;
	    if (*mode == 1) {
		fmt_(&a, maxc, &typ, &n1, &n2);
	    }
	    if (typ == 2) {
		fl = n1;
		iw[ldef] = n2 + (n1 << 5);
	    } else if (typ < 0) {
		iw[ldef] = typ;
		fl = 3;
	    } else {
		iw[ldef] = 1;
		fl = *maxc;
		n2 = *maxc - 7;
	    }

 

 

 

 
	    lgh = fl + 3;
 
	    ++ldef;

 
	    i__3 = iw[k];
	    iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ;
 
	}
	s += iw[k];
	if (s > *ll - 2) {
	    iw[lbloc + nbloc] = k - 1;
	    ++nbloc;
	    iw[lbloc + nbloc] = *n;
	    s = iw[k];
	}

 
    }

    if (fact != 1.) {
	ici__1.icierr = 0;
	ici__1.icirnum = 1;
	ici__1.icirlen = 12;
	ici__1.iciunit = cw;
	ici__1.icifmt = "(1x,1pd9.1,' *')";
	s_wsfi(&ici__1);
	d__1 = 1. / fact;
	do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
	e_wsfi();
	basout_(&io, lunit, cw, 12L);
	basout_(&io, lunit, " ", 1L);
	if (io == -1) {
	    goto L99;
	}
    }
 

 

    k1 = 1;
    i__2 = nbloc;
    for (ib = 1; ib <= i__2; ++ib) {
	k2 = iw[lbloc + ib];
	if (nbloc != 1) {
	    if (k1 == k2) {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 4;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__4[0] = 16, a__1[0] = "         column ";
		i__4[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__4, &c__2, 20L);
		basout_(&io, lunit, ch__1, 20L);
	    } else {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 8;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(2i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__5[0] = 16, a__2[0] = "        columns ";
		i__5[1] = 4, a__2[1] = cw;
		i__5[2] = 3, a__2[2] = " to";
		i__5[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__5, &c__4, 27L);
		basout_(&io, lunit, ch__2, 27L);
		basout_(&io, lunit, " ", 1L);
	    }
	    basout_(&io, lunit, " ", 1L);
	    if (io == -1) {
		goto L99;
	    }
	}

	*(unsigned char *)cw = *(unsigned char *)dl;
	i__1 = *m;
	for (l = 1; l <= i__1; ++l) {
	    ldef = lf + l - 1 + (k1 - 1) * *m;
	    l1 = 2;
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		a = x[l + (k - 1) * *nx] * fact;
 
		if ((( a ) >= 0 ? ( a ) : -( a ))  < eps && *mode != 0) {
		    a = 0.;
		}

		l0 = l1;
		ifmt = iw[ldef];
		*(unsigned char *)sgn = ' ';
		if (a < 0.) {
		    *(unsigned char *)sgn = '-';
		}
		a = (( a ) >= 0 ? ( a ) : -( a )) ;

 
		i__4[0] = 1, a__1[0] = " ";
		i__4[1] = 1, a__1[1] = sgn;
		s_cat(cw + (l1 - 1), a__1, i__4, &c__2, 2L);
		l1 += 2;

		if (ifmt == 1) {
		    nf = 1;
		    fl = *maxc;
		    n2 = 1;
		    ici__1.icierr = 0;
		    ici__1.icirnum = 1;
		    ici__1.icirlen = l1 + fl - 1 - (l1 - 1);
		    ici__1.iciunit = cw + (l1 - 1);
		    ici__1.icifmt = form + (nf - 1) * 10;
		    s_wsfi(&ici__1);
		    do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
		    e_wsfi();
		} else if (ifmt >= 0) {
		    nf = 2;
		    n1 = ifmt / 32;
		    n2 = ifmt - (n1 << 5);
		    fl = n1;
		    ici__1.icierr = 0;
		    ici__1.icirnum = 1;
		    ici__1.icirlen = 10;
		    ici__1.iciunit = form + (nf - 1) * 10;
		    ici__1.icifmt = fmt_120;
		    s_wsfi(&ici__1);
		    do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer));
		    e_wsfi();
		    ici__1.icierr = 0;
		    ici__1.icirnum = 1;
		    ici__1.icirlen = l1 + fl - 1 - (l1 - 1);
		    ici__1.iciunit = cw + (l1 - 1);
		    ici__1.icifmt = form + (nf - 1) * 10;
		    s_wsfi(&ici__1);
		    do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
		    e_wsfi();
		} else if (ifmt == -1) {
 
		    fl = 3;
		    s_copy(cw + (l1 - 1), "Inf", l1 + fl - 1 - (l1 - 1), 3L);
		} else if (ifmt == -2) {
 
		    fl = 3;
		    s_copy(cw + (l1 - 1), "Nan", l1 + fl - 1 - (l1 - 1), 3L);
		}
		l1 += fl;

 
		nl1 = l0 + iw[k] - 1;
		s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		l1 = nl1 + 1;
		ldef += *m;
 
	    }
	    *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
	    basout_(&io, lunit, cw, l1);
	    if (io == -1) {
		goto L99;
	    }
 
	}
	k1 = k2 + 1;
 
    }

L99:
    return 0;

}  

 
  int dmdspf_(x, nx, m, n, maxc, ll, lunit)
doublereal *x;
integer *nx, *m, *n, *maxc, *ll, *lunit;
{
     
    static char fmt_130[] = "(\002(1x,\002,i2,\002(1pd\002,i2,\002.\002,i2,\002,2x))\002)";

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3[2], i__4[4], i__5;
    char ch__1[21], ch__2[28];

     
    integer s_wsfi(), do_fio(), e_wsfi();
      int s_cat();

     
    static integer ncol;
    static char form[20];
    static integer k, l, nbloc, k1, k2, ib, io;
    static char cw[20];
    extern   int basout_();
    static char buf[80];

     
    static icilist io___3437 = { 0, form, 0, fmt_130, 20, 1 };
    static icilist io___3442 = { 0, cw, 0, "(i4)", 4, 1 };
    static icilist io___3443 = { 0, cw, 0, "(2i4)", 8, 1 };
    static icilist io___3446 = { 0, buf, 0, form, 80, 1 };


 
 
 
 
 

 

 
 


 
 
 
 
 
 
 
 
 

     
    --x;

     
    io = 0;
    ncol = *ll / (*maxc + 2);
    nbloc = (*n + ncol - 1) / ncol;

    s_wsfi(&io___3437);
    do_fio(&c__1, (char *)&ncol, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer));
    i__1 = *maxc - 7;
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    e_wsfi();

    k1 = 1;
    i__1 = nbloc;
    for (ib = 1; ib <= i__1; ++ib) {
 
	i__2 = k1 - 1 + ncol;
	k2 = (( i__2 ) <= ( *n ) ? ( i__2 ) : ( *n )) ;
	if (nbloc != 1) {
	    if (k1 == k2) {
		s_wsfi(&io___3442);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__3[0] = 17, a__1[0] = "         colonne ";
		i__3[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__3, &c__2, 21L);
		basout_(&io, lunit, ch__1, 21L);
	    } else {
		s_wsfi(&io___3443);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__4[0] = 17, a__2[0] = "        colonnes ";
		i__4[1] = 4, a__2[1] = cw;
		i__4[2] = 3, a__2[2] = " a ";
		i__4[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__4, &c__4, 28L);
		basout_(&io, lunit, ch__2, 28L);
		basout_(&io, lunit, " ", 1L);
	    }
	    basout_(&io, lunit, " ", 1L);
	    if (io == -1) {
		goto L99;
	    }
	}

	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
	    s_wsfi(&io___3446);
	    i__5 = k2;
	    for (k = k1; k <= i__5; ++k) {
		do_fio(&c__1, (char *)&x[l + (k - 1) * *nx], (ftnlen)sizeof(
			doublereal));
	    }
	    e_wsfi();
	    basout_(&io, lunit, buf, 80L);
	    if (io == -1) {
		goto L99;
	    }
 
	}
	k1 = k2 + 1;
 
    }

L99:
    return 0;

}  

 
  int dmp2pm_(mp, d__, nl, pm, deg, m, n)
doublereal *mp;
integer *d__, *nl;
doublereal *pm;
integer *deg, *m, *n;
{
     
    integer i__1, i__2, i__3, i__4;

     
    extern   int dset_();
    static integer k, l;
    extern   int dcopy_();
    static integer mn, kij, imp, ipm;

 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

 
 

 
 
 

     
    --pm;
    --d__;
    --mp;

     
    mn = *m * *n;
    i__1 = mn * (*deg + 1);
    dset_(&i__1, &c_b61, &pm[1], &c__1);

    imp = -(*nl);
    ipm = -(*m);
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	imp += *nl;
	ipm += *m;
	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
 
	    i__3 = *deg + 1, i__4 = d__[imp + l + 1] - d__[imp + l];
	    kij = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
	    dcopy_(&kij, &mp[d__[imp + l]], &c__1, &pm[l + ipm], &mn);
 
	}
 
    }
    return 0;
}  

 
  int dmpad_(pm1, d1, l1, pm2, d2, l2, pm3, d3, m, n)
doublereal *pm1;
integer *d1, *l1;
doublereal *pm2;
integer *d2, *l2;
doublereal *pm3;
integer *d3, *m, *n;
{
     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2, d__3, d__4;

     
    static integer i__, j, k;
    static doublereal w;
    static integer i1, i2, k1, n1, n2, n3, k3, k2;
    extern doublereal dlamch_();
    static integer mn;
    static doublereal eps;

 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 


     
    --d3;
    --pm3;
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    eps = dlamch_("p", 1L);
    mn = *m * *n;
    d3[1] = 1;

    i1 = -(*l1);
    i2 = -(*l2);
    k3 = 0;
 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *l1;
	i2 += *l2;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[i1 + i__] - 1;
	    k2 = d2[i2 + i__] - 1;
	    n1 = d1[i1 + i__ + 1] - d1[i1 + i__];
	    n2 = d2[i2 + i__ + 1] - d2[i2 + i__];
	    if (n1 > n2) {
		goto L30;
	    }

 

 
	    i__3 = n1;
	    for (k = 1; k <= i__3; ++k) {
		w = pm1[k1 + k] + pm2[k2 + k];
 
		d__3 = (d__1 = pm1[k1 + k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__4 = (d__2 = pm2[k2 
			+ k], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) );
		if ((( w ) >= 0 ? ( w ) : -( w ))  > (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 ))  * eps) {
		    pm3[k3 + k] = w;
		} else {
		    pm3[k3 + k] = 0.;
		}
 
	    }
	    if (n1 == n2) {
		goto L23;
	    }
	    n3 = n1 + 1;
	    i__3 = n2;
	    for (k = n3; k <= i__3; ++k) {
		pm3[k3 + k] = pm2[k2 + k];
 
	    }
L23:
	    n3 = n2;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;
	    goto L38;

 

L30:
	    i__3 = n2;
	    for (k = 1; k <= i__3; ++k) {
		w = pm1[k1 + k] + pm2[k2 + k];
 
		d__3 = (d__1 = pm1[k1 + k], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__4 = (d__2 = pm2[k2 
			+ k], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) );
		if ((( w ) >= 0 ? ( w ) : -( w ))  > (( d__3 ) >= ( d__4 ) ? ( d__3 ) : ( d__4 ))  * eps) {
		    pm3[k3 + k] = w;
		} else {
		    pm3[k3 + k] = 0.;
		}
 
	    }
	    n3 = n2 + 1;
	    i__3 = n1;
	    for (k = n3; k <= i__3; ++k) {
		pm3[k3 + k] = pm1[k1 + k];
 
	    }
	    n3 = n1;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;

L38:
	    k1 += n1;
	    k2 += n2;
	    k3 += n3;
 
	}
 
    }
    return 0;
}  

 
  int dmpadj_(pm1, d1, m, n)
doublereal *pm1;
integer *d1, *m, *n;
{
     
    integer i__1;

     
    static integer j;
    extern   int dcopy_();
    static integer k1, n1, dj, kk;

 
 

 

 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 


     
    --d1;
    --pm1;

     
    kk = 1;
    dj = 1;
 
    i__1 = *m * *n;
    for (j = 1; j <= i__1; ++j) {
	k1 = dj - 1;
	n1 = d1[j + 1] - dj + 1;
L10:
	--n1;
	if (pm1[k1 + n1] == 0. && n1 > 1) {
	    goto L10;
	}
	if (kk != k1 + 1) {
	    dcopy_(&n1, &pm1[k1 + 1], &c__1, &pm1[kk], &c__1);
	}
	kk += n1;
	dj = d1[j + 1];
	d1[j + 1] = kk;
 
    }

    return 0;
}  

  int dmpcle_(pm1, d1, m, n, d2, epsr, epsa)
doublereal *pm1;
integer *d1, *m, *n, *d2;
doublereal *epsr, *epsa;
{
     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    static integer lmin, lmax, ivol;
    static doublereal norm;
    static integer k, l;
    extern   int dcopy_();
    static integer count, l1, ll;
    static logical ok;
    static integer mn, ld1;
    static doublereal eps;

 
 
 
 
 

 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 



     
    --d2;
    --d1;
    --pm1;

     
    mn = *m * *n;
    ld1 = mn + 1;
    if (mn == 1) {
	lmin = d1[1];
	lmax = d1[2] - 1;
	norm = 0.;
	i__1 = lmax;
	for (l = lmin; l <= i__1; ++l) {
	    norm += (d__1 = pm1[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
	}
 
	d__1 = *epsa, d__2 = *epsr * norm;
	eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	ll = lmax + 1;
	count = 0;
	ok = (0) ;
	i__1 = lmax;
	for (k = lmin; k <= i__1; ++k) {
	    --ll;
	    if ((d__1 = pm1[ll], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) {
		pm1[ll] = 0.;
		if (ll == lmax) {
		    ok = (1) ;
		}
		if (ok == (1) ) {
		    ++count;
		}
	    } else {
		ok = (0) ;
	    }
 
	}
	d1[2] -= count;
	if (d1[2] <= d1[1]) {
	    d1[2] = d1[1] + 1;
	}
	return 0;
    }
    i__1 = ld1;
    for (k = 1; k <= i__1; ++k) {
	d2[k] = d1[k];
 
    }
    i__1 = mn;
    for (k = 1; k <= i__1; ++k) {
	lmin = d2[k];
	lmax = d2[k + 1] - 1;
	norm = 0.;
	i__2 = lmax;
	for (l = lmin; l <= i__2; ++l) {
	    norm += (d__1 = pm1[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
 
	}
 
	d__1 = *epsa, d__2 = *epsr * norm;
	eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	ll = lmax + 1;
	count = 0;
	ok = (0) ;
	i__2 = lmax;
	for (l = lmin; l <= i__2; ++l) {
	    --ll;
	    if ((d__1 = pm1[ll], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) {
		if (ll == lmax) {
		    ok = (1) ;
		}
		if (ok == (1) ) {
		    ++count;
		}
		pm1[ll] = 0.;
	    } else {
		ok = (0) ;
	    }
 
	}
	d1[k + 1] = d1[k] + d2[k + 1] - d2[k] - count;
	if (d1[k + 1] <= d1[k]) {
	    d1[k + 1] = d1[k] + 1;
	}
 
    }
    l1 = d1[2];
    i__1 = mn;
    for (k = 2; k <= i__1; ++k) {
	lmin = d2[k];
	ivol = d1[k + 1] - d1[k];
	dcopy_(&ivol, &pm1[lmin], &c__1, &pm1[l1], &c__1);
	l1 += ivol;
 
    }
    return 0;
}  

 
  int dmpcnc_(pm1, d1, ld1, pm2, d2, ld2, pm3, d3, l, m, n, 
	job)
doublereal *pm1;
integer *d1, *ld1;
doublereal *pm2;
integer *d2, *ld2;
doublereal *pm3;
integer *d3, *l, *m, *n, *job;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int dcopy_();
    static integer i1, i2, i3, np;

 
 
 
 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --d3;
    --pm3;
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    i3 = 1;
    d3[1] = 1;
    i1 = 1 - *ld1;
    i2 = 1 - *ld2;

    if (*job < 0) {
	goto L30;
    }

    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	np = d1[i1 + *l] - d1[i1];
	dcopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
 
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i2 += *ld2;
	np = d2[i2 + *l] - d2[i2];
	dcopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;

L30:
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	i2 += *ld2;
	np = d1[i1 + *l] - d1[i1];
	dcopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
	np = d2[i2 + *m] - d2[i2];
	dcopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;
}  

  int dmpdsp_(mp, d__, nl, m, n, var, lvar, maxc, mode, ll, 
	lunit, cw, iw, var_len, cw_len)
doublereal *mp;
integer *d__, *nl, *m, *n;
char *var;
integer *lvar, *maxc, *mode, *ll, *lunit;
char *cw;
integer *iw;
ftnlen var_len;
ftnlen cw_len;
{
     
    static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_110[] = "(\002(i\002,i2,\002)\002)";

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3, i__4[2], i__5[4], i__6, i__7;
    real r__1;
    doublereal d__1;
    char ch__1[20], ch__2[27];
    icilist ici__1;

     
      int s_copy();
    integer s_wsfi(), do_fio(), e_wsfi();
    double r_lg10();
      int s_cat();
    integer s_cmp();

     
    static integer ldef, ifmt;
    static char fexp[10], form[10*2], expo[10];
    static doublereal a;
    static integer i__, j, k, l, lbloc, nbloc, lines, c1, c2;
    static logical first;
    static integer k0, k1, k2, n1, n2, l1, l2, l0, ib;
    static char dl[1];
    static integer fl, lf, nd, nf, io, lp, sk, sl, np;
    extern   int basout_();
    static integer ll1, nl1, ldg, lgh;
    extern   int fmt_();
    static char sgn[1];
    static integer typ;

     
    static icilist io___3493 = { 0, form, 0, fmt_130, 10, 1 };
    static icilist io___3533 = { 0, fexp, 0, fmt_110, 10, 1 };
    static icilist io___3535 = { 0, expo, 0, fexp, 10, 1 };


 
 
 
 
 

 
 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

     
    --iw;
    --d__;
    --mp;

     
    s_copy(cw, " ", cw_len, 1L);
    s_wsfi(&io___3493);
    do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer));
    i__1 = *maxc - 7;
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    e_wsfi();
    *(unsigned char *)dl = ' ';
    if (*m * *n > 1) {
	*(unsigned char *)dl = '!';
    }

 

 
 
 
 
 
 

    lines = 0;
    lbloc = *n;
    lf = lbloc + 2 + *n;
    nbloc = 1;
    iw[lbloc + nbloc] = *n;
    sk = 0;

    ldg = -(*nl);
    ldef = lf;
    k0 = 1;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	sl = 0;
	iw[k] = 0;
	ldg += *nl;
	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {

 
	    lp = d__[ldg + l] - 1;
	    np = d__[ldg + l + 1] - d__[ldg + l];
	    lgh = 0;
	    first = (1) ;
	    i__3 = np;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		a = (d__1 = mp[lp + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		iw[ldef] = 0;
		if (a == 0.) {
		    goto L9;
		}
		first = (0) ;
 
		typ = 1;
		if (*mode == 1) {
		    fmt_(&a, maxc, &typ, &n1, &n2);
		}
		if (typ == 2) {
		    fl = n1;
		    iw[ldef] = n2 + (n1 << 5);
		} else if (typ < 0) {
		    iw[ldef] = typ;
		    fl = 3;
		} else {
		    iw[ldef] = 1;
		    fl = *maxc;
		    n2 = *maxc - 7;
		}

 

 

 
		lgh = lgh + fl + 2;
		if (n2 == 0) {
		    --lgh;
		    if (i__ != 1 && (integer) (a + (float).1) == 1) {
			--lgh;
		    }
		}
		if (i__ != 1) {
		    lgh += *lvar;
		}
L9:
		++ldef;
 
	    }

 
	    r__1 = np + (float).5;
	    nd = (integer) r_lg10(&r__1) + 1;
	    lgh += nd;
 
	    if (first) {
		lgh = 4;
	    }

 
	    i__3 = iw[k];
	    iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ;
	    sl = sl + lgh / (*ll - 2) + 1;

 
	}
	sk += iw[k];
	if (sk > *ll - 2) {
	    if (k == k0) {
		iw[lbloc + nbloc] = k;
		sk = 0;
		k0 = k + 1;
	    } else {
		iw[lbloc + nbloc] = k - 1;
		sk = iw[k];
		k0 = k;
	    }
	    ++nbloc;
	    iw[lbloc + nbloc] = *n;
	    lines = lines + (sl << 1) + *m + 2;
	}
 
    }
    nbloc = (( nbloc ) <= ( *n ) ? ( nbloc ) : ( *n )) ;


 
 
 

    k1 = 1;
    i__1 = nbloc;
    for (ib = 1; ib <= i__1; ++ib) {
	k2 = iw[lbloc + ib];
	ll1 = 0;
	if (nbloc != 1) {
	    if (k1 == k2) {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 4;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__4[0] = 16, a__1[0] = "         column ";
		i__4[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__4, &c__2, 20L);
		basout_(&io, lunit, ch__1, 20L);
	    } else {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 8;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(2i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__5[0] = 16, a__2[0] = "        columns ";
		i__5[1] = 4, a__2[1] = cw;
		i__5[2] = 3, a__2[2] = " to";
		i__5[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__5, &c__4, 27L);
		basout_(&io, lunit, ch__2, 27L);
		basout_(&io, lunit, " ", 1L);
	    }
	    if (io == -1) {
		goto L99;
	    }
	}

	*(unsigned char *)cw = *(unsigned char *)dl;
	c1 = 2;
	i__2 = *ll;
	s_copy(cw + i__2, dl, *ll + 1 - i__2, 1L);
	c2 = *ll + 2;

	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
	    l1 = c1;
	    l2 = c2;
	    if (iw[k1] > *ll - 2) {
		ll1 = *ll;
	    }
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		ldg = (k - 1) * *nl + l;
		lp = d__[ldg] - 1;
		np = d__[ldg + 1] - d__[ldg];
		ldef = lf - 1 + d__[ldg] - d__[1];
		first = (1) ;

		l0 = l1;
		i__6 = np;
		for (j = 1; j <= i__6; ++j) {
		    ifmt = iw[ldef + j];
		    if (ifmt == 0) {
			goto L45;
		    }
		    *(unsigned char *)sgn = '+';
		    if (first) {
			*(unsigned char *)sgn = ' ';
		    }
		    first = (0) ;
		    if (mp[lp + j] < 0.) {
			*(unsigned char *)sgn = '-';
		    }
		    a = (d__1 = mp[lp + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

		    if (ifmt == 1) {
			nf = 1;
			fl = *maxc;
			n2 = 1;
		    } else if (ifmt >= 0) {
			nf = 2;
			n1 = ifmt / 32;
			n2 = ifmt - (n1 << 5);
			fl = n1;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = 10;
			ici__1.iciunit = form + (nf - 1) * 10;
			ici__1.icifmt = fmt_120;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer));
			e_wsfi();
		    } else if (ifmt < 0) {
 
			fl = 3;
			n2 = 1;
		    }

		    nd = 0;
		    if (j > 2) {
			r__1 = j + (float).5;
			nd = (integer) r_lg10(&r__1) + 1;
		    }
		    if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) {
 
			if (l1 <= *ll - 1) {
			    s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L)
				    ;
			}
			if (l2 <= c2 + *ll - 3) {
			    s_copy(cw + (l2 - 1), " ", c2 + *ll - 3 - (l2 - 1)
				    , 1L);
			}
			*(unsigned char *)&cw[*ll - 1] = *(unsigned char *)dl;
			i__7 = c1 - 2;
			basout_(&io, lunit, cw + i__7, *ll - i__7);
			i__7 = c2 + *ll - 3;
			s_copy(cw + i__7, dl, c2 + *ll - 2 - i__7, 1L);
			i__7 = c2 - 2;
			basout_(&io, lunit, cw + i__7, c2 + *ll - 2 - i__7);
			if (io == -1) {
			    goto L99;
			}
			s_copy(cw + (c2 - 1), " ", 10L, 1L);
			l2 = c2 + 10;
			s_copy(cw + (c1 - 1), " ", 10L, 1L);
			l1 = c1 + 10;
		    }
 
 
		    i__4[0] = 1, a__1[0] = " ";
		    i__4[1] = 1, a__1[1] = sgn;
		    s_cat(cw + (l2 - 1), a__1, i__4, &c__2, 2L);
		    ++l2;
		    if (ifmt >= 0) {
			i__7 = l2;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = l2 + fl - i__7;
			ici__1.iciunit = cw + i__7;
			ici__1.icifmt = form + (nf - 1) * 10;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
			e_wsfi();
		    } else if (ifmt == -1) {
			i__7 = l2;
			s_copy(cw + i__7, "Inf", l2 + fl - i__7, 3L);
		    } else if (ifmt == -2) {
			i__7 = l2;
			s_copy(cw + i__7, "Nan", l2 + fl - i__7, 3L);
		    }
		    l2 += fl;
		    if (n2 == 0) {
			--l2;
		    }
		    if (j > 1) {
			if (n2 == 0 && (integer) (a + (float).1) == 1) {
			    --l2;
			}
			i__7 = l2;
			s_copy(cw + i__7, var, l2 + *lvar - i__7, (*lvar));
			l2 += *lvar;
		    }
		    nl1 = l2 + c1 - c2;
		    s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		    if (j > 2) {
			s_wsfi(&io___3533);
			do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer));
			e_wsfi();
			s_wsfi(&io___3535);
			i__7 = j - 1;
			do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
			e_wsfi();
			i__7 = nl1;
			s_copy(cw + i__7, expo, nl1 + nd - i__7, nd);
			l1 = nl1 + nd;
		    }
		    ++l1;
		    ++l2;
L45:
		    ;
		}
		if (first) {
 
		    s_copy(cw + (l1 - 1), " ", 4L, 1L);
		    s_copy(cw + (l2 - 1), "   0", 4L, 4L);
		    l1 += 4;
		    l2 += 4;
		    nd = 0;
		}
		if (nd != 0) {
		    s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L);
		}
		nl1 = l0 + iw[k];
		if (ll1 == *ll) {
		    nl1 = *ll - 1;
		}
		s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		l1 = nl1 + 1;
		s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L);
		l2 = c2 + nl1 - c1 + 1;
 
	    }
	    if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) {
 
 
		*(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
		i__3 = c1 - 2;
		basout_(&io, lunit, cw + i__3, l1 - i__3);
	    }
	    *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
	    i__3 = c2 - 2;
	    basout_(&io, lunit, cw + i__3, l2 - i__3);
	    if (l != *m) {
		s_copy(cw + (c2 - 1), " ", l2 - 1 - (c2 - 1), 1L);
		i__3 = c2 - 2;
		basout_(&io, lunit, cw + i__3, l2 - i__3);
	    }
	    if (io == -1) {
		goto L99;
	    }
 
	}
	k1 = k2 + 1;
 
    }

L99:
    return 0;


}  

 
  int dmpext_(mp, d__, m, n, row, nr, col, nc, mp1, d1, job, 
	ierr)
doublereal *mp;
integer *d__, *m, *n, *row, *nr, *col, *nc;
doublereal *mp1;
integer *d1, *job, *ierr;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j;
    extern   int dcopy_();
    static integer id, id1, idi;

 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

     
    --d1;
    --mp1;
    --col;
    --row;
    --d__;
    --mp;

     
    if (*nr * *nc == 0) {
	return 0;
    }
    if (*m <= 0 || *n <= 0) {
	return 0;
    }
    if (*nr < 0) {
	goto L40;
    }
    if (*nc < 0) {
	goto L50;
    }

 

 
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	if (col[j] <= 0 || col[j] > *n) {
	    goto L100;
	}
 
    }
    i__1 = *nr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (row[i__] <= 0 || row[i__] > *m) {
	    goto L100;
	}
 
    }

    if (*job == 1) {
	goto L25;
    }
 
    d1[1] = 1;
    id1 = 1;
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__2 = *nr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++id1;
 
	    d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 
		    1];
	}
    }
    if (*job == 0) {
	return 0;
    }

L25:
    id1 = 1;
    i__2 = *nc;
    for (j = 1; j <= i__2; ++j) {
	id = *m * (col[j] - 1);
	i__1 = *nr;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ++id1;
	    i__3 = d1[id1] - d1[id1 - 1];
	    dcopy_(&i__3, &mp[d__[id + row[i__]]], &c__1, &mp1[d1[id1 - 1]], &
		    c__1);
 
	}
    }
    return 0;

L40:
    if (*nc < 0) {
	goto L60;
    }
 
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	if (col[j] <= 0 || col[j] > *n) {
	    goto L100;
	}
 
    }
    if (*job == 1) {
	goto L45;
    }
    id1 = 1;
    d1[id1] = 1;
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++id1;
	    d1[id1] = d1[id1 - 1] + d__[id + i__] - d__[id + i__ - 1];
 
	}
    }
    if (*job == 0) {
	return 0;
    }
L45:
    id1 = 1;
    i__2 = *nc;
    for (j = 1; j <= i__2; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__1 = d__[id + *m] - d__[id];
	dcopy_(&i__1, &mp[d__[id]], &c__1, &mp1[d1[id1]], &c__1);
	id1 += *m;
 
    }
    return 0;

L50:
 
    i__2 = *nr;
    for (i__ = 1; i__ <= i__2; ++i__) {
	if (row[i__] <= 0 || row[i__] > *m) {
	    goto L100;
	}
 
    }
    if (*job == 1) {
	goto L55;
    }
    id1 = 1;
    d1[1] = 1;
    id = 1 - *m;
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	id += *m;
	i__1 = *nr;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ++id1;
	    d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 
		    1];
 
	}
    }
    if (*job == 0) {
	return 0;
    }
L55:
    id1 = 1;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	id = (j - 1) * *m;
	i__2 = *nr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    idi = id + row[i__];
	    i__3 = d__[idi + 1] - d__[idi];
	    dcopy_(&i__3, &mp[d__[idi]], &c__1, &mp1[d1[id1]], &c__1);
	    ++id1;
 
	}
    }
    return 0;

L60:
 
    if (*job == 1) {
	goto L65;
    }
    i__2 = *m * *n + 1;
    for (i__ = 1; i__ <= i__2; ++i__) {
	d1[i__] = d__[i__];
 
    }
    if (*job == 0) {
	return 0;
    }
L65:
    i__2 = d__[*m * *n + 1] - 1;
    dcopy_(&i__2, &mp[1], &c__1, &mp1[1], &c__1);
    return 0;
L100:
    *ierr = 1;
    return 0;
}  

 
  int dmpins_(mat1, dep1, lig1, col1, mat2, dep2, lig2, col2, 
	matr, depr, ligr, colr)
doublereal *mat1;
integer *dep1, *lig1, *col1;
doublereal *mat2;
integer *dep2, *lig2, *col2;
doublereal *matr;
integer *depr, *ligr, *colr;
{
     
    integer i__1, i__2;

     
    static integer i__, j, l;
    extern   int dcopy_();
    static integer l1, l2, kr, lr;

 

 
 
 
 

 

 
 

 

 

 
 

 

 
 

 
 


 

 
 

 
 


 

     
    --depr;
    --matr;
    --dep2;
    --mat2;
    --dep1;
    --mat1;

     
    depr[1] = 1;
    kr = 1;

    i__1 = *colr;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *ligr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++kr;
	    lr = depr[kr];
	    if (lr < 0) {
		goto L11;
	    } else if (lr == 0) {
		goto L12;
	    } else {
		goto L13;
	    }
L11:
	    l2 = -lr;
	    l = dep2[l2 + 1] - dep2[l2];
	    dcopy_(&l, &mat2[dep2[l2]], &c__1, &matr[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;
	    goto L20;
L12:
	    matr[depr[kr - 1]] = 0.;
	    depr[kr] = depr[kr - 1] + 1;
	    goto L20;
L13:
	    l1 = lr;
	    l = dep1[l1 + 1] - dep1[l1];
	    dcopy_(&l, &mat1[dep1[l1]], &c__1, &matr[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;

L20:
	    ;
	}
    }
    return 0;
}  

 
  int dmpmu_(mp1, d1, nl1, mp2, d2, nl2, mp3, d3, l, m, n)
doublereal *mp1;
integer *d1, *nl1;
doublereal *mp2;
integer *d2, *nl2;
doublereal *mp3;
integer *d3, *l, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k;
    extern   int dpmul_();
    static integer k1, k2, k3, p1, p2, p3;

 
 
 

 

 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
 
 

 
 
 

 
 
 

 
 
 
 

 



     
    --d3;
    --mp3;
    --d2;
    --mp2;
    --d1;
    --mp1;

     
    d3[1] = 1;
    if (*l == 0 || *m == 0 || *n == 0) {
	goto L500;
    }

    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    mp3[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    p1 = i__ - *nl1;
	    i__3 = *m;
	    for (k = 1; k <= i__3; ++k) {
		p1 += *nl1;
		k2 = d2[p2 + k + 1] - d2[p2 + k] - 1;
		k1 = d1[p1 + 1] - d1[p1] - 1;
		dpmul_(&mp1[d1[p1]], &k1, &mp2[d2[p2 + k]], &k2, &mp3[d3[p3 + 
			i__]], &k3);
 
	    }
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
 
    }
    return 0;
L500:
    if (*l == 0) {
	goto L600;
    }
    if (*m == 0) {
	goto L700;
    }
    p1 = -(*nl1);
    p3 = -(*l);
    k2 = d2[2] - d2[1] - 1;
    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k3 = 0;
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    mp3[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1[d1[p1 + i__]], &k1, &mp2[1], &k2, &mp3[d3[p3 + i__]], 
		    &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L600:
    k1 = d1[2] - d1[1] - 1;
    p2 = -(*nl2);
    p3 = -(*m);
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	p2 += *nl2;
	p3 += *m;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    k3 = 0;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1[1], &k1, &mp2[d2[p2 + i__]], &k2, &mp3[d3[p3 + i__]], 
		    &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L700:
    p1 = -(*nl1);
    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    dpmul_(&mp1[d1[p1 + i__]], &k1, &mp2[d2[p2 + i__]], &k2, &mp3[d3[
		    p3 + i__]], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
}  

 
  int dmptld_(pm1, d1, ld1, pm2, d2, m, n)
doublereal *pm1;
integer *d1, *ld1;
doublereal *pm2;
integer *d2, *m, *n;
{
     
    integer i__1, i__2, i__3;
    doublereal d__1;

     
    extern   int dset_();
    static integer nmax;
    static doublereal norm;
    static integer i__, j;
    extern doublereal dasum_();
    extern   int dcopy_();
    static integer i1, i2, l1, l2, n1;

 
 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
     
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    d2[1] = 1;
    nmax = 0;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1 + 1;
	    i__3 = n1 - 1;
	    norm = dasum_(&i__3, &pm1[l1], &c__1);
L10:
	    --n1;
	    if ((d__1 = pm1[l1 + n1 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + norm <= norm) {
		goto L10;
	    }
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = n1;
	    nmax = (( nmax ) >= ( n1 ) ? ( nmax ) : ( n1 )) ;
 
	}
 
    }

 
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    n1 = d2[i2 + 1];
	    l2 = d2[i2];
	    if (n1 < nmax) {
		i__3 = nmax - n1;
		dset_(&i__3, &c_b61, &pm2[l2], &c__1);
	    }
	    dcopy_(&n1, &pm1[d1[i1]], &c__1, &pm2[l2 + nmax - n1], &c_n1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + nmax;
 
	}
 
    }

    return 0;
}  

 
  int dmptra_(pm1, d1, ld1, pm2, d2, m, n)
doublereal *pm1;
integer *d1, *ld1;
doublereal *pm2;
integer *d2, *m, *n;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int dcopy_();
    static integer i1, i2, l1, l2, n1;

 
 

 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
     
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1;
	    l2 = d2[i2];
	    dcopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + n1;
 
	}
 
    }

    return 0;
}  

  int dmrdsp_(mpn, dn, mpd, dd, nl, m, n, var, lvar, maxc, 
	mode, ll, lunit, cw, iw, var_len, cw_len)
doublereal *mpn;
integer *dn;
doublereal *mpd;
integer *dd, *nl, *m, *n;
char *var;
integer *lvar, *maxc, *mode, *ll, *lunit;
char *cw;
integer *iw;
ftnlen var_len;
ftnlen cw_len;
{
     

    static integer nind = 5;

     
    static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_110[] = "(\002(i\002,i2,\002)\002)";

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2], i__8[4];
    real r__1;
    doublereal d__1;
    char ch__1[15], ch__2[24];
    icilist ici__1;

     
      int s_copy();
    integer s_wsfi(), do_fio(), e_wsfi();
    double r_lg10();
      int s_cat();
    integer s_cmp();

     
    static integer ideb, ldeb, lghd, ifin, lcol, lfin, lghn, ifmt;
    static char fexp[10], form[10*2], expo[10];
    static doublereal a;
    static integer i__, j, k, l, ldefd, ldefn, lbloc, nbloc, lines, c1, c2;
    static logical first;
    static integer k0, k1, k2, n1, n2, l1, l2, l0, ib;
    static char dl[1];
    static integer fl, nd, nf, io, sk, sl, idelta, ldelta, ndelta;
    extern   int basout_();
    static integer ll1, nl1, lfd, ldg, lfn, lpd, npd;
    extern   int fmt_();
    static char sgn[1];
    static integer lpn, npn, typ, jjb1;

     
    static icilist io___3575 = { 0, form, 0, fmt_130, 10, 1 };
    static icilist io___3626 = { 0, fexp, 0, fmt_110, 10, 1 };
    static icilist io___3628 = { 0, expo, 0, fexp, 10, 1 };
    static icilist io___3632 = { 0, fexp, 0, fmt_110, 10, 1 };
    static icilist io___3633 = { 0, expo, 0, fexp, 10, 1 };


 
 
 
 
 

 
 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --iw;
    --dd;
    --mpd;
    --dn;
    --mpn;

     

    s_copy(cw, " ", cw_len, 1L);
    s_wsfi(&io___3575);
    do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer));
    i__1 = *maxc - 7;
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    e_wsfi();
    *(unsigned char *)dl = ' ';
    if (*m * *n > 1) {
	*(unsigned char *)dl = '!';
    }

 

 
 
 
 
 
 

    lcol = 1;
    lbloc = lcol + *n - 1;
    lfn = lbloc + *n + 2;
    lfd = lfn + dn[*n * *m + 1];
    ldelta = lfd + dd[*n * *m + 1];
    ldeb = ldelta + *m * *n;
    lfin = ldeb + *n;

    lines = 0;
    nbloc = 1;
    iw[lbloc + nbloc] = *n;
    sk = 0;
    ldefn = lfn;
    ldg = -(*nl);
    ldefd = lfd;
    idelta = ldelta;

    k0 = 1;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	sl = 0;
	iw[lcol - 1 + k] = 0;
	ldg += *nl;
	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {

 
	    lpn = dn[ldg + l] - 1;
	    npn = dn[ldg + l + 1] - dn[ldg + l];
	    lghn = 0;
	    first = (1) ;
	    i__3 = npn;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		a = (d__1 = mpn[lpn + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		iw[ldefn] = 0;
		if (a != 0.) {
		    first = (0) ;
 
		    typ = 1;
		    if (*mode == 1) {
			fmt_(&a, maxc, &typ, &n1, &n2);
		    }
		    if (typ == 2) {
			fl = n1;
			iw[ldefn] = n2 + (n1 << 5);
		    } else if (typ < 0) {
			iw[ldefn] = typ;
			n2 = 1;
			fl = 3;
		    } else {
			iw[ldefn] = 1;
			fl = *maxc;
			n2 = *maxc - 7;
		    }

 

 

 
		    lghn = lghn + fl + 2;
		    if (n2 == 0) {
			--lghn;
			if (i__ != 1 && (integer) (a + (float).1) == 1) {
			    --lghn;
			}
		    }
		    if (i__ != 1) {
			lghn += *lvar;
		    }
		}
		++ldefn;
 
	    }

 
	    r__1 = npn + (float).5;
	    nd = (integer) r_lg10(&r__1) + 1;
	    lghn += nd;
 
	    if (first) {
		lghn = 4;
	    }

	    lpd = dd[ldg + l] - 1;
	    npd = dd[ldg + l + 1] - dd[ldg + l];
	    lghd = 0;
	    first = (1) ;
	    i__3 = npd;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		a = (d__1 = mpd[lpd + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
		iw[ldefd] = 0;
		if (a != 0.) {
		    first = (0) ;
 
		    typ = 1;
		    if (*mode == 1) {
			fmt_(&a, maxc, &typ, &n1, &n2);
		    }
		    if (typ == 2) {
			fl = n1;
			iw[ldefd] = n2 + (n1 << 5);
		    } else if (typ < 0) {
			iw[ldefd] = typ;
			n2 = 1;
			fl = 3;
		    } else {
			iw[ldefd] = 1;
			fl = *maxc;
			n2 = *maxc - 7;
		    }
 

 

 
		    lghd = lghd + fl + 2;
		    if (n2 == 0) {
			--lghd;
			if (i__ != 1 && (integer) (a + (float).1) == 1) {
			    --lghd;
			}
		    }
		    if (i__ != 1) {
			lghd += *lvar;
		    }
		}
		++ldefd;
 
	    }

 
	    r__1 = npd + (float).5;
	    nd = (integer) r_lg10(&r__1) + 1;
	    lghd += nd;
 
	    if (first) {
		lghd = 4;
	    }

 
	    i__3 = iw[k], i__3 = (( i__3 ) >= ( lghn ) ? ( i__3 ) : ( lghn )) ;
	    iw[k] = (( i__3 ) >= ( lghd ) ? ( i__3 ) : ( lghd )) ;
	    sl = sl + lghn / (*ll - 10) + lghd / (*ll - 10) + 2;
 
	    i__3 = lghn, i__4 = *ll - 2;
 
	    i__5 = lghd, i__6 = *ll - 2;
	    iw[idelta] = (( i__3 ) <= ( i__4 ) ? ( i__3 ) : ( i__4 ))  - (( i__5 ) <= ( i__6 ) ? ( i__5 ) : ( i__6 )) ;
	    ++idelta;

 
	}
	sk += iw[k];
	if (sk > *ll - 2) {
	    if (k == k0) {
		iw[lbloc + nbloc] = k;
		sk = 0;
		k0 = k + 1;
	    } else {
		iw[lbloc + nbloc] = k - 1;
		sk = iw[k];
		k0 = k;
	    }
	    ++nbloc;
	    iw[lbloc + nbloc] = *n;
 
	}
 
    }
    nbloc = (( nbloc ) <= ( *n ) ? ( nbloc ) : ( *n )) ;


 
 
 

    k1 = 1;
    i__1 = nbloc;
    for (ib = 1; ib <= i__1; ++ib) {
	k2 = iw[lbloc + ib];
	ll1 = 0;
	if (nbloc != 1) {
	    if (k1 == k2) {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 4;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__7[0] = 11, a__1[0] = "    column ";
		i__7[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__7, &c__2, 15L);
		basout_(&io, lunit, ch__1, 15L);
	    } else {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 8;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(2i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__8[0] = 12, a__2[0] = "    columns ";
		i__8[1] = 4, a__2[1] = cw;
		i__8[2] = 4, a__2[2] = " to ";
		i__8[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__8, &c__4, 24L);
		basout_(&io, lunit, ch__2, 24L);
		basout_(&io, lunit, " ", 1L);
	    }
	    if (io == -1) {
		goto L99;
	    }
	}

	*(unsigned char *)cw = *(unsigned char *)dl;
	c1 = 2;
	i__2 = *ll;
	s_copy(cw + i__2, dl, *ll + 1 - i__2, 1L);
 
	i__2 = *ll + 3, i__3 = nind + *maxc + 15;
	c2 = (( i__2 ) >= ( i__3 ) ? ( i__2 ) : ( i__3 )) ;

	i__2 = *m;
	for (l = 1; l <= i__2; ++l) {
 
	    l1 = c1;
	    l2 = c2;
	    if (iw[k1] > *ll - 2) {
		ll1 = *ll;
	    }
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		l0 = l1;
		idelta = ldelta - 1 + l + (k - 1) * *m;
		ndelta = 0;
		if (iw[idelta] < -1) {
		    ndelta = -iw[idelta] / 2;
		    s_copy(cw + (l1 - 1), " ", l1 + ndelta - 1 - (l1 - 1), 1L)
			    ;
		    s_copy(cw + (l2 - 1), " ", l2 + ndelta - 1 - (l2 - 1), 1L)
			    ;
		    l1 += ndelta;
		    l2 += ndelta;
		}

		ldg = (k - 1) * *nl + l;
		lpn = dn[ldg] - 1;
		npn = dn[ldg + 1] - dn[ldg];
		ldefn = lfn - 1 + dn[ldg] - dn[1];
		first = (1) ;

		iw[ldeb - 1 + k] = l2;
		iw[lfin - 1 + k] = 0;
		i__4 = npn;
		for (j = 1; j <= i__4; ++j) {
		    ifmt = iw[ldefn + j];
		    if (ifmt == 0) {
			goto L40;
		    }
		    *(unsigned char *)sgn = '+';
		    if (first) {
			*(unsigned char *)sgn = ' ';
		    }
		    first = (0) ;
		    if (mpn[lpn + j] < 0.) {
			*(unsigned char *)sgn = '-';
		    }
		    a = (d__1 = mpn[lpn + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

		    if (ifmt == 1) {
			nf = 1;
			fl = *maxc;
			n2 = 1;
		    } else if (ifmt >= 0) {
			nf = 2;
			n1 = ifmt / 32;
			n2 = ifmt - (n1 << 5);
			fl = n1;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = 10;
			ici__1.iciunit = form + (nf - 1) * 10;
			ici__1.icifmt = fmt_120;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer));
			e_wsfi();
		    } else if (ifmt < 0) {
 
			fl = 3;
			n2 = 1;
		    }

		    nd = 0;
		    if (j > 2) {
			r__1 = j + (float).5;
			nd = (integer) r_lg10(&r__1) + 1;
		    }
		    if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) {
 
			if (l1 <= *ll - 1) {
			    s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L)
				    ;
			    l1 = *ll;
			}
			if (l2 <= c2 + *ll - 2) {
			    s_copy(cw + (l2 - 1), " ", c2 + *ll - 2 - (l2 - 1)
				    , 1L);
			    l2 = c2 + *ll - 2;
			}
			iw[lfin - 1 + k] = l2 - 1;
			*(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
			i__5 = c1 - 2;
			basout_(&io, lunit, cw + i__5, l1 - i__5);
			*(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
			i__5 = c2 - 2;
			s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L);
			i__5 = c2 - 2;
			basout_(&io, lunit, cw + i__5, l2 - i__5);
			if (io == -1) {
			    goto L99;
			}
			i__5 = c2 - 2;
			s_copy(cw + i__5, " ", c2 + nind - 1 - i__5, 1L);
			i__5 = c2 - 2;
			s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L);
			l2 = c2 + nind;
			i__5 = c1 - 2;
			s_copy(cw + i__5, " ", c1 + nind - 1 - i__5, 1L);
			i__5 = c1 - 2;
			s_copy(cw + i__5, dl, c1 - 1 - i__5, 1L);
			l1 = c1 + nind;
		    }
 
 
		    i__7[0] = 1, a__1[0] = " ";
		    i__7[1] = 1, a__1[1] = sgn;
		    s_cat(cw + (l2 - 1), a__1, i__7, &c__2, 2L);
		    ++l2;
		    if (ifmt >= 0) {
			i__5 = l2;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = l2 + fl - i__5;
			ici__1.iciunit = cw + i__5;
			ici__1.icifmt = form + (nf - 1) * 10;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
			e_wsfi();
		    } else if (ifmt == -1) {
			i__5 = l2;
			s_copy(cw + i__5, "Inf", l2 + fl - i__5, 3L);
		    } else if (ifmt == -2) {
			i__5 = l2;
			s_copy(cw + i__5, "Nan", l2 + fl - i__5, 3L);
		    }
		    l2 += fl;
		    if (n2 == 0) {
			--l2;
		    }
		    if (j > 1) {
			if (n2 == 0 && (integer) (a + (float).1) == 1) {
			    --l2;
			}
			i__5 = l2;
			s_copy(cw + i__5, var, l2 + *lvar - i__5, (*lvar));
			l2 += *lvar;
		    }
		    nl1 = l2 + c1 - c2;
		    s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		    if (j > 2) {
			s_wsfi(&io___3626);
			do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer));
			e_wsfi();
			s_wsfi(&io___3628);
			i__5 = j - 1;
			do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
			e_wsfi();
			i__5 = nl1;
			s_copy(cw + i__5, expo, nl1 + nd - i__5, nd);
			l1 = nl1 + nd;
		    }
		    ++l1;
		    ++l2;
L40:
		    ;
		}
		if (first) {
 
		    s_copy(cw + (l1 - 1), " ", 4L, 1L);
		    s_copy(cw + (l2 - 1), "   0", 4L, 4L);
		    l1 += 4;
		    l2 += 4;
		    nd = 0;
		}
		if (iw[lfin - 1 + k] == 0) {
		    iw[lfin - 1 + k] = l2;
		}
		if (nd != 0) {
		    s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L);
		}
		nl1 = l0 + iw[k];
		if (ll1 == *ll) {
		    nl1 = *ll - 1;
		}
		s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		l1 = nl1 + 1;
		s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L);
		l2 = c2 + nl1 - c1 + 1;
 
	    }
	    if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) {
		*(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
		i__3 = c1 - 2;
		basout_(&io, lunit, cw + i__3, l1 - i__3);
	    }
	    *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
	    i__3 = c2 - 2;
	    s_copy(cw + i__3, dl, c2 - 1 - i__3, 1L);
	    i__3 = c2 - 2;
	    basout_(&io, lunit, cw + i__3, l2 - i__3);
	    if (io == -1) {
		goto L99;
	    }

 
	    s_copy(cw + (c2 - 1), " ", l2 - 1 - (c2 - 1), 1L);
	    jjb1 = c2;
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		idelta = ldelta - 1 + l + (k - 1) * *m;
 
		i__4 = 0, i__5 = -iw[idelta] / 2;
		ndelta = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;
 
		i__4 = jjb1, i__5 = iw[ldeb - 1 + k] - ndelta + 2;
		ideb = (( i__4 ) >= ( i__5 ) ? ( i__4 ) : ( i__5 )) ;
		ifin = iw[lfin - 1 + k] + ndelta - 2;
		if (ifin - ideb + 1 == 2) {
		    --ideb;
		}
		i__4 = ifin;
		for (i__ = ideb; i__ <= i__4; ++i__) {
		    i__5 = i__;
		    s_copy(cw + i__5, "-", i__ + 1 - i__5, 1L);
 
		}
		jjb1 = iw[lfin - 1 + k] + 1;
 
	    }
	    *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
	    i__3 = c2 - 2;
	    basout_(&io, lunit, cw + i__3, l2 - i__3);
	    if (io == -1) {
		goto L99;
	    }

 
	    l1 = c1;
	    l2 = c2;
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		l0 = l1;
		idelta = ldelta - 1 + l + (k - 1) * *m;
		ndelta = 0;
		if (iw[idelta] > 1) {
		    ndelta = iw[idelta] / 2;
		    s_copy(cw + (l1 - 1), " ", l1 + ndelta - 1 - (l1 - 1), 1L)
			    ;
		    s_copy(cw + (l2 - 1), " ", l2 + ndelta - 1 - (l2 - 1), 1L)
			    ;
		    l1 += ndelta;
		    l2 += ndelta;
		}

		ldg = (k - 1) * *nl + l;
		lpd = dd[ldg] - 1;
		npd = dd[ldg + 1] - dd[ldg];
		ldefd = lfd - 1 + dd[ldg] - dd[1];
		first = (1) ;

		i__4 = npd;
		for (j = 1; j <= i__4; ++j) {
		    ifmt = iw[ldefd + j];
		    if (ifmt == 0) {
			goto L50;
		    }
		    *(unsigned char *)sgn = '+';
		    if (first) {
			*(unsigned char *)sgn = ' ';
		    }
		    first = (0) ;
		    if (mpd[lpd + j] < 0.) {
			*(unsigned char *)sgn = '-';
		    }
		    a = (d__1 = mpd[lpd + j], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );

		    if (ifmt == 1) {
			nf = 1;
			fl = *maxc;
			n2 = 1;
		    } else if (ifmt >= 0) {
			nf = 2;
			n1 = ifmt / 32;
			n2 = ifmt - (n1 << 5);
			fl = n1;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = 10;
			ici__1.iciunit = form + (nf - 1) * 10;
			ici__1.icifmt = fmt_120;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer));
			e_wsfi();
		    } else if (ifmt < 0) {
 
			fl = 3;
			n2 = 1;
		    }

		    nd = 0;
		    if (j > 2) {
			r__1 = j + (float).5;
			nd = (integer) r_lg10(&r__1) + 1;
		    }
		    if (l2 + fl + 2 + *lvar + nd > c2 + *ll - 2) {
 
			if (l1 <= *ll - 1) {
			    s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L)
				    ;
			    l1 = *ll;
			}
			if (l2 <= c2 + *ll - 2) {
			    s_copy(cw + (l2 - 1), " ", c2 + *ll - 2 - (l2 - 1)
				    , 1L);
			    l2 = c2 + *ll - 2;
			}
			*(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
			i__5 = c1 - 2;
			basout_(&io, lunit, cw + i__5, l1 - i__5);
			*(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
			i__5 = c2 - 2;
			basout_(&io, lunit, cw + i__5, l2 - i__5);
			if (io == -1) {
			    goto L99;
			}
			s_copy(cw + (c2 - 1), " ", c2 - 1 + nind - (c2 - 1), 
				1L);
			i__5 = c2 - 2;
			s_copy(cw + i__5, dl, c2 - 1 - i__5, 1L);
			l2 = c2 + nind;
			s_copy(cw + (c1 - 1), " ", c1 - 1 + nind - (c1 - 1), 
				1L);
			i__5 = c1 - 2;
			s_copy(cw + i__5, dl, c1 - 1 - i__5, 1L);
			l1 = c1 + nind;
		    }
 
 
		    i__7[0] = 1, a__1[0] = " ";
		    i__7[1] = 1, a__1[1] = sgn;
		    s_cat(cw + (l2 - 1), a__1, i__7, &c__2, 2L);
		    ++l2;
		    if (ifmt >= 0) {
			i__5 = l2;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = l2 + fl - i__5;
			ici__1.iciunit = cw + i__5;
			ici__1.icifmt = form + (nf - 1) * 10;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
			e_wsfi();
		    } else if (ifmt == -1) {
			i__5 = l2;
			s_copy(cw + i__5, "Inf", l2 + fl - i__5, 3L);
		    } else if (ifmt == -2) {
			i__5 = l2;
			s_copy(cw + i__5, "Nan", l2 + fl - i__5, 3L);
		    }
		    l2 += fl;
		    if (n2 == 0) {
			--l2;
		    }
		    if (j > 1) {
			if (n2 == 0 && (integer) (a + (float).1) == 1) {
			    --l2;
			}
			i__5 = l2;
			s_copy(cw + i__5, var, l2 + *lvar - i__5, (*lvar));
			l2 += *lvar;
		    }
		    nl1 = l2 + c1 - c2;
		    s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		    if (j > 2) {
			s_wsfi(&io___3632);
			do_fio(&c__1, (char *)&nd, (ftnlen)sizeof(integer));
			e_wsfi();
			s_wsfi(&io___3633);
			i__5 = j - 1;
			do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
			e_wsfi();
			i__5 = nl1;
			s_copy(cw + i__5, expo, nl1 + nd - i__5, nd);
			l1 = nl1 + nd;
		    }
		    ++l1;
		    ++l2;
L50:
		    ;
		}
		if (first) {
 
		    s_copy(cw + (l1 - 1), " ", 4L, 1L);
		    s_copy(cw + (l2 - 1), "   0", 4L, 4L);
		    l1 += 4;
		    l2 += 4;
		    nd = 0;
		}
		if (nd != 0) {
		    s_copy(cw + (l2 - 1), " ", l2 + nd - 1 - (l2 - 1), 1L);
		}
		nl1 = l0 + iw[k];
		if (ll1 == *ll) {
		    nl1 = *ll - 1;
		}
		s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		l1 = nl1 + 1;
		s_copy(cw + (l2 - 1), " ", c2 + nl1 - c1 - (l2 - 1), 1L);
		l2 = c2 + nl1 - c1 + 1;
 
	    }
	    if (s_cmp(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L) != 0) {
		*(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
		i__3 = c1 - 2;
		basout_(&io, lunit, cw + i__3, l1 - i__3);
	    }
	    *(unsigned char *)&cw[l2 - 1] = *(unsigned char *)dl;
	    i__3 = c2 - 2;
	    s_copy(cw + i__3, dl, c2 - 1 - i__3, 1L);
	    i__3 = c2 - 2;
	    basout_(&io, lunit, cw + i__3, l2 - i__3);
	    s_copy(cw + (c1 - 1), " ", l1 - 1 - (c1 - 1), 1L);
	    *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
	    if (io == -1) {
		goto L99;
	    }
	    if (l != *m) {
		i__3 = c1 - 2;
		basout_(&io, lunit, cw + i__3, l1 - i__3);
		if (io == -1) {
		    goto L99;
		}
	    }
 
	}

	k1 = k2 + 1;
 
    }

L99:
    return 0;


}  

 
  int dpmul_(p1, d1, p2, d2, p3, d3)
doublereal *p1;
integer *d1;
doublereal *p2;
integer *d2;
doublereal *p3;
integer *d3;
{
     
    integer i__1, i__2;
    doublereal d__1, d__2, d__3;

     
    static integer dmin__, dmax__;
    extern doublereal ddot_();
    static integer dsum, i__, j, k, l;
    static doublereal w;
    static integer e1, e2;
    static doublereal w1;
    extern doublereal dlamch_();
    static doublereal eps;

 
 

 

 
 
 
 
 
 
 
 
     
    --p3;
    --p2;
    --p1;

     
    eps = dlamch_("p", 1L);
 
    dsum = *d1 + *d2;
 
    dmax__ = *d1;
    if (*d2 > *d1) {
	dmax__ = *d2;
    }
    dmin__ = dsum - dmax__;
 
    if (*d3 >= dsum) {
	goto L1;
    }
    e1 = *d3 + 2;
    e2 = dsum + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	p3[i__] = 0.;
 
    }
    *d3 = dsum;
L1:
 
    if (*d1 == 0 || *d2 == 0) {
	goto L53;
    }
 
    e1 = 1;
    e2 = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	w = ddot_(&i__, &p1[1], &c__1, &p2[1], &c_n1);
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    k = 1;
    if (*d1 == *d2) {
	goto L21;
    }
    e1 = dmin__ + 2;
    e2 = dmax__ + 1;
 
    if (*d1 < *d2) {
	goto L25;
    }
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	++k;
	i__2 = dmin__ + 1;
	w = ddot_(&i__2, &p1[k], &c__1, &p2[1], &c_n1);
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
L21:
    e1 = dmax__ + 2;
    e2 = dsum + 1;
    l = 1;
    j = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	--j;
	++k;
	++l;
	w = ddot_(&j, &p1[k], &c__1, &p2[l], &c_n1);
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    return 0;
 
L25:
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	++k;
	i__2 = dmin__ + 1;
	w = ddot_(&i__2, &p2[k], &c_n1, &p1[1], &c__1);
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    e1 = dmax__ + 2;
    e2 = dsum + 1;
    l = 1;
    j = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	--j;
	++k;
	++l;
	w = ddot_(&j, &p1[l], &c__1, &p2[k], &c_n1);
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    return 0;
 
L53:
    if (*d1 == 0 && *d2 == 0) {
	goto L100;
    }
    e1 = 1;
    if (*d1 == 0) {
	goto L60;
    }
    e2 = *d1 + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	w = p1[i__] * p2[1];
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    return 0;
L60:
    e2 = *d2 + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	w = p2[i__] * p1[1];
	w1 = p3[i__] + w;
 
	d__2 = (d__1 = p3[i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ), d__3 = (( w ) >= 0 ? ( w ) : -( w )) ;
	if ((( w1 ) >= 0 ? ( w1 ) : -( w1 ))  > eps * (( d__2 ) >= ( d__3 ) ? ( d__2 ) : ( d__3 )) ) {
	    p3[i__] = w1;
	} else {
	    p3[i__] = 0.;
	}
 
    }
    return 0;
L100:
    p3[1] += p1[1] * p2[1];
    return 0;
}  

 
  int dpmul1_(p1, d1, p2, d2, p3)
doublereal *p1;
integer *d1;
doublereal *p2;
integer *d2;
doublereal *p3;
{
     
    integer i__1;

     
    extern doublereal ddot_();
    static integer k, l, d3, l1, l2, l3, m3;

 
 

 

 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
     
    --p3;
    --p2;
    --p1;

     
    l = 1;
    l1 = *d1 + 1;
    l2 = *d2 + 1;
    d3 = *d1 + *d2;
    l3 = d3 + 1;

    m3 = (( l1 ) <= ( l2 ) ? ( l1 ) : ( l2 )) ;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	p3[l3] = ddot_(&l, &p1[l1], &c__1, &p2[l2], &c_n1);
	++l;
	--l3;
	--l1;
	--l2;
 
    }
    --l;

    if (l1 == 0) {
	goto L30;
    }
    m3 = l1;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	p3[l3] = ddot_(&l, &p1[l1], &c__1, &p2[1], &c_n1);
	--l1;
	--l3;
 
    }
    goto L40;
L30:
    if (l2 == 0) {
	goto L40;
    }
    m3 = l2;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	p3[l3] = ddot_(&l, &p1[1], &c__1, &p2[l2], &c_n1);
	--l2;
	--l3;
 
    }

L40:
    if (l3 == 0) {
	return 0;
    }
    m3 = l3;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	--l;
	p3[l3] = ddot_(&l, &p1[1], &c__1, &p2[1], &c_n1);
	--l3;
 
    }
    return 0;
}  

 
  int dpodiv_(a, b, na, nb)
doublereal *a, *b;
integer *na, *nb;
{
     
    integer i__1;

     
    static integer i__, l, n;
    static doublereal q;
    static integer n1, n2, nb1;


 
 
 
 
 
 
 
 
 

 
 
 

     
    --b;
    --a;

     
    l = *na - *nb + 1;
L2:
    if (l <= 0) {
	goto L5;
    } else {
	goto L3;
    }
L3:
    n = l + *nb;
    q = a[n] / b[*nb + 1];
    nb1 = *nb + 1;
    i__1 = nb1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	n1 = *nb - i__ + 2;
	n2 = n - i__ + 1;
 
	a[n2] -= b[n1] * q;
    }
    a[n] = q;
    --l;
    goto L2;
L5:
    return 0;
}  

 
  int dprxc_(n, roots, coeff)
integer *n;
doublereal *roots, *coeff;
{
     
    integer i__1;
    doublereal d__1;

     
    extern   int dset_();
    static integer j;
    extern   int daxpy_();
    static integer nj;

 
 
 

 
 
 
 

 
 
 
 
 
 
 
 
 


     
    --roots;
    --coeff;

     
    dset_(n, &c_b61, &coeff[1], &c__1);
    coeff[*n + 1] = 1.;

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	nj = *n + 1 - j;
	d__1 = -roots[j];
	daxpy_(&j, &d__1, &coeff[nj + 1], &c__1, &coeff[nj], &c__1);
 
    }

    return 0;
}  

  int dpsimp_(a, na, b, nb, a1, na1, b1, nb1, w, ierr)
doublereal *a;
integer *na;
doublereal *b;
integer *nb;
doublereal *a1;
integer *na1;
doublereal *b1;
integer *nb1;
doublereal *w;
integer *ierr;
{
     
    integer i__1;
    doublereal d__1;

     
    static integer nden;
    extern   int dset_();
    static integer maxw, nnum;
    static doublereal t;
    extern   int dscal_();
    static integer lfree;
    extern   int dcopy_();
    static integer n0;
    static doublereal er;
    static integer lw, nz;
    extern   int recbez_();
    static integer la0, lb0, ipb[6];

 
 
 

 
 
 

 
 

 
 
 
 
 
 

 
 
 
 
 
 

 
 

 

 

 
 
 
 

 
 
 
 
 
 


     
    --a;
    --b;
    --a1;
    --b1;
    --w;

     
    lw = (*na + *nb << 1) + 1 + (( *na ) <= ( *nb ) ? ( *na ) : ( *nb ))  + 3;
 
 

    maxw = *ierr;
    *ierr = 0;

 
    la0 = 0;
L10:
    ++la0;
    if (la0 > *na + 1) {
	goto L20;
    }
    if (a[la0] == 0.) {
	goto L10;
    }
    *na1 = *na - (la0 - 1);
    nz = la0 - 1;

    lb0 = 0;
L11:
    ++lb0;
    if (lb0 > *nb + 1) {
	*ierr = 1;
	return 0;
    }
    if (b[lb0] == 0.) {
	goto L11;
    }
    *nb1 = *nb - (lb0 - 1);
    nz -= lb0 - 1;

    n0 = (( *na1 ) >= ( *nb1 ) ? ( *na1 ) : ( *nb1 ))  + 1;
    lfree = lw + n0 * 10 + n0 * 3 * n0;
    if (lfree >= maxw && *na1 > 0 && *nb1 > 0) {
	*ierr = 2;
    }
    if (lfree >= maxw || *na1 == 0 || *nb1 == 0) {
	goto L30;
    }

    recbez_(&a[la0], na1, &b[lb0], nb1, &w[1], ipb, &w[lw], &er);
    if (er > .001) {
	goto L30;
    }
    nden = ipb[4] - ipb[3];
    nnum = ipb[5] - ipb[4];
    if (*na1 != nnum - 1) {
	t = w[ipb[4] - 1];
	t = 1. / t;
	if (nz == 0) {
	    dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[1], &c__1);
	    d__1 = -t;
	    dscal_(&nnum, &d__1, &a1[1], &c__1);
	    dcopy_(&nden, &w[ipb[3]], &c__1, &b1[1], &c__1);
	    dscal_(&nden, &t, &b1[1], &c__1);
	} else if (nz > 0) {
	    dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[nz + 1], &c__1);
	    dset_(&nz, &c_b61, &a1[1], &c__1);
	    d__1 = -t;
	    dscal_(&nnum, &d__1, &a1[nz + 1], &c__1);
	    nnum += nz;
	    dcopy_(&nden, &w[ipb[3]], &c__1, &b1[1], &c__1);
	    dscal_(&nden, &t, &b1[1], &c__1);
	} else if (nz < 0) {
	    nz = -nz;
	    dcopy_(&nnum, &w[ipb[4]], &c__1, &a1[1], &c__1);
	    d__1 = -t;
	    dscal_(&nnum, &d__1, &a1[1], &c__1);
	    dcopy_(&nden, &w[ipb[3]], &c__1, &b1[nz + 1], &c__1);
	    dset_(&nz, &c_b61, &b1[1], &c__1);
	    dscal_(&nden, &t, &b1[nz + 1], &c__1);
	    nden += nz;
	}
    } else {
 
	if (nz == 0) {
	    dcopy_(&nnum, &a[la0], &c__1, &a1[1], &c__1);
	    dcopy_(&nden, &b[lb0], &c__1, &b1[1], &c__1);
 
 
	} else if (nz > 0) {
	    dcopy_(&nnum, &a[la0], &c__1, &a1[nz + 1], &c__1);
	    dset_(&nz, &c_b61, &a1[1], &c__1);
 
	    nnum += nz;
	    dcopy_(&nden, &b[lb0], &c__1, &b1[1], &c__1);
 
	} else {
	    nz = -nz;
	    dcopy_(&nnum, &a[la0], &c__1, &a1[1], &c__1);
 
	    dcopy_(&nden, &b[lb0], &c__1, &b1[nz + 1], &c__1);
	    dset_(&nz, &c_b61, &b1[1], &c__1);
 
	    nden += nz;
	}
    }
    *na1 = nnum;
    *nb1 = nden;
    return 0;
L20:
    a1[1] = 0.;
    b1[1] = 1.;
    *na1 = 1;
    *nb1 = 1;
    return 0;
L30:
    if (nz == 0) {
	i__1 = *na1 + 1;
	dcopy_(&i__1, &a[la0], &c__1, &a1[1], &c__1);
	i__1 = *nb1 + 1;
	dcopy_(&i__1, &b[lb0], &c__1, &b1[1], &c__1);
    } else if (nz > 0) {
	dset_(&nz, &c_b61, &a1[1], &c__1);
	i__1 = *na1 + 1;
	dcopy_(&i__1, &a[la0], &c__1, &a1[nz + 1], &c__1);
	i__1 = *nb1 + 1;
	dcopy_(&i__1, &b[lb0], &c__1, &b1[1], &c__1);
	*na1 += nz;
    } else {
	i__1 = *na1 + 1;
	dcopy_(&i__1, &a[la0], &c__1, &a1[1], &c__1);
	i__1 = -nz;
	dset_(&i__1, &c_b61, &b1[1], &c__1);
	i__1 = *nb1 + 1;
	dcopy_(&i__1, &b[lb0], &c__1, &b1[-nz + 1], &c__1);
	*nb1 -= nz;
    }
    ++(*na1);
    ++(*nb1);
    return 0;
}  

 
  int dwmpmu_(mp1r, d1, nl1, mp2r, mp2i, d2, nl2, mp3r, mp3i, 
	d3, l, m, n)
doublereal *mp1r;
integer *d1, *nl1;
doublereal *mp2r, *mp2i;
integer *d2, *nl2;
doublereal *mp3r, *mp3i;
integer *d3, *l, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k;
    extern   int dpmul_();
    static integer k1, k2, k3, p1, p2, p3, kk;

 
 
 


 

 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
 
 

 
 
 

 
 
 

 
 
 


 



     
    --d3;
    --mp3i;
    --mp3r;
    --d2;
    --mp2i;
    --mp2r;
    --d1;
    --mp1r;

     
    d3[1] = 1;
    if (*l == 0 || *m == 0 || *n == 0) {
	goto L500;
    }

    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    p1 = i__ - *nl1;
	    i__3 = *m;
	    for (k = 1; k <= i__3; ++k) {
		p1 += *nl1;
		k2 = d2[p2 + k + 1] - d2[p2 + k] - 1;
		k1 = d1[p1 + 1] - d1[p1] - 1;
		kk = k3;
		dpmul_(&mp1r[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3r[d3[
			p3 + i__]], &kk);
		dpmul_(&mp1r[d1[p1]], &k1, &mp2i[d2[p2 + k]], &k2, &mp3i[d3[
			p3 + i__]], &k3);
 
	    }
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
 
    }
    return 0;
L500:
    if (*l == 0) {
	goto L600;
    }
    if (*m == 0) {
	goto L700;
    }
    p1 = -(*nl1);
    p3 = -(*l);
    k2 = d2[2] - d2[1] - 1;
    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k3 = 0;
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    kk = k3;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3r[d3[p3 + i__]
		    ], &kk);
	    mp3i[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2i[1], &k2, &mp3i[d3[p3 + i__]
		    ], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L600:
    k1 = d1[2] - d1[1] - 1;
    p2 = -(*nl2);
    p3 = -(*m);
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	p2 += *nl2;
	p3 += *m;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    k3 = 0;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    kk = k3;
	    dpmul_(&mp1r[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__]
		    ], &kk);
	    mp3i[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1r[1], &k1, &mp2i[d2[p2 + i__]], &k2, &mp3i[d3[p3 + i__]
		    ], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L700:
    p1 = -(*nl1);
    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[
		    d3[p3 + i__]], &k3);
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2i[d2[p2 + i__]], &k2, &mp3i[
		    d3[p3 + i__]], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
}  

 
  int fmt_(a, maxc, typ, n1, n2)
doublereal *a;
integer *maxc, *typ, *n1, *n2;
{
     
    integer i__1, i__2;
    doublereal d__1;

     
    double d_mod(), d_lg10(), pow_di();

     
    static integer ndgt, m;
    static logical v;
    static doublereal a1;
    extern doublereal round_();
    static logical t1, t2;
    extern doublereal dlamch_();
    static doublereal dec, ent;

 
 
 
 
 

 
 

 
 
 
 
 
 
 
 
 
 
 

 
    v = (0) ;
    t1 = *a <= 1.;
    t2 = *a >= 1.;
    if (! t1 && ! t2) {
	v = (1) ;
    }
    if (v) {
	*typ = -2;
	return 0;
    } else if (*a > dlamch_("o", 1L)) {
	*typ = -1;
	return 0;
    }
    if (*maxc - 3 <= 0) {
	goto L30;
    }
    if (*a < 1.) {
	goto L20;
    }
    a1 = d_mod(a, &c_b8137);
    ent = *a - a1 + (integer) a1;
    dec = *a - ent;
    ndgt = (integer) d_lg10(&ent) + 1;
    if (ndgt < 0) {
	ndgt = *maxc;
    }
    if (ndgt <= *maxc - 2) {
	goto L10;
    }
    if (*maxc - 7 < 0) {
	goto L30;
    }
    *typ = 1;
    *n1 = *maxc;
    *n2 = *maxc - 7;
    return 0;
L10:
    *n1 = ndgt + 2;
    *typ = 2;
    ndgt = *maxc - *n1;
    *n2 = 0;
    i__1 = ndgt + 1;
    a1 = dec * pow_di(&c_b8137, &i__1);
 
    d__1 = a1 / 10.;
    dec = round_(&d__1);
    if (dec == 0.) {
	return 0;
    }
    *n2 = ndgt;
L11:
    if (d_mod(&dec, &c_b8137) != 0.) {
	goto L12;
    }
    --(*n2);
    dec /= 10.;
    goto L11;
L12:
    *n1 += *n2;
    return 0;

L20:
    ndgt = 0;
    if (*a == 0.) {
	goto L26;
    }
    m = (integer) (1 - d_lg10(a));
    ndgt = *maxc - 3 + m;
    if (m >= *maxc - 3) {
	goto L25;
    }
    d__1 = *a * pow_di(&c_b8137, &ndgt);
    dec = round_(&d__1);
L21:
    if (d_mod(&dec, &c_b8137) != 0.) {
	goto L22;
    }
    dec /= 10.;
    --ndgt;
    goto L21;
L22:
    if (ndgt <= *maxc - 3) {
	goto L26;
    }
    *n1 = *maxc - 3;
 
    i__1 = *maxc - 7, i__2 = ndgt - m;
    *n2 = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    if (*n1 >= *n2) {
	goto L26;
    }
L25:
    if (*maxc - 7 < 0) {
	goto L26;
    }
    *typ = 1;
    *n1 = *maxc;
    *n2 = *maxc - 7;
    return 0;
L26:
    *typ = 2;
 
    i__1 = ndgt, i__2 = *maxc - 3;
    *n2 = (( i__1 ) <= ( i__2 ) ? ( i__1 ) : ( i__2 )) ;
    *n1 = *n2 + 3;
    return 0;
L30:
    *typ = 2;
    *n1 = *maxc;
    *n2 = 0;
    return 0;
}  

 
  int horner_(p, dp, xr, xi, vr, vi)
doublereal *p;
integer *dp;
doublereal *xr, *xi, *vr, *vi;
{
     
    integer i__1;

     
    static integer i__;
    static doublereal t;
    static integer ip;

 
 
 
 
 

 
 

 
 
 
 
 
 
 
 

     
    --p;

     
    ip = *dp + 1;
    *vr = p[ip];
    *vi = 0.;
    if (*dp == 0) {
	return 0;
    }
    if (*xi != 0.) {
	goto L20;
    }
 
    i__1 = *dp;
    for (i__ = 1; i__ <= i__1; ++i__) {
	*vr = *vr * *xr + p[ip - i__];
 
    }
    return 0;

 
L20:
    i__1 = *dp;
    for (i__ = 1; i__ <= i__1; ++i__) {
	t = *vr * *xr - *vi * *xi + p[ip - i__];
	*vi = *vi * *xr + *vr * *xi;
	*vr = t;
 
    }
    return 0;

}  

 
  int idegre_(a, majo, nvrai)
doublereal *a;
integer *majo, *nvrai;
{
     
    integer i__1;
    doublereal d__1;

     
    static doublereal test;
    static integer k;
    extern doublereal dasum_();
    static doublereal an;
    static integer kk;

 
 
 
 
 
 
 

     
    --a;

     
    i__1 = *majo + 1;
    an = dasum_(&i__1, &a[1], &c__1);
    if (an == 0.) {
	goto L20;
    }
    if (*majo == 0) {
	goto L20;
    }
    i__1 = *majo + 1;
    for (k = 1; k <= i__1; ++k) {
	kk = *majo + 2 - k;
	test = (d__1 = a[kk], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / an;
	if (test + 1. != 1.) {
	    *nvrai = kk - 1;
	    return 0;
	}
 
    }
L20:
    *nvrai = 0;
    return 0;
}  

 
  int impcnc_(pm1, d1, ld1, pm2, d2, ld2, pm3, d3, l, m, n, 
	job)
integer *pm1, *d1, *ld1, *pm2, *d2, *ld2, *pm3, *d3, *l, *m, *n, *job;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int icopy_();
    static integer i1, i2, i3, np;

 
 
 
 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --d3;
    --pm3;
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    i3 = 1;
    d3[1] = 1;
    i1 = 1 - *ld1;
    i2 = 1 - *ld2;

    if (*job < 0) {
	goto L30;
    }

    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	np = d1[i1 + *l] - d1[i1];
	icopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
 
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i2 += *ld2;
	np = d2[i2 + *l] - d2[i2];
	icopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;

L30:
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	i2 += *ld2;
	np = d1[i1 + *l] - d1[i1];
	icopy_(&np, &pm1[d1[i1]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
	np = d2[i2 + *m] - d2[i2];
	icopy_(&np, &pm2[d2[i2]], &c__1, &pm3[d3[i3]], &c__1);
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;
}  

 
  int impext_(mp, d__, m, n, row, nr, col, nc, mp1, d1, job, 
	ierr)
integer *mp, *d__, *m, *n, *row, *nr, *col, *nc, *mp1, *d1, *job, *ierr;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j;
    extern   int icopy_();
    static integer id, id1, idi;

 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

     
    --d1;
    --mp1;
    --col;
    --row;
    --d__;
    --mp;

     
    if (*nr * *nc == 0) {
	return 0;
    }
    if (*m <= 0 || *n <= 0) {
	return 0;
    }
    if (*nr < 0) {
	goto L40;
    }
    if (*nc < 0) {
	goto L50;
    }

 

 
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	if (col[j] <= 0 || col[j] > *n) {
	    goto L100;
	}
 
    }
    i__1 = *nr;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (row[i__] <= 0 || row[i__] > *m) {
	    goto L100;
	}
 
    }

    if (*job == 1) {
	goto L25;
    }
 
    d1[1] = 1;
    id1 = 1;
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__2 = *nr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++id1;
 
	    d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 
		    1];
	}
    }
    if (*job == 0) {
	return 0;
    }

L25:
    id1 = 1;
    i__2 = *nc;
    for (j = 1; j <= i__2; ++j) {
	id = *m * (col[j] - 1);
	i__1 = *nr;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ++id1;
	    i__3 = d1[id1] - d1[id1 - 1];
	    icopy_(&i__3, &mp[d__[id + row[i__]]], &c__1, &mp1[d1[id1 - 1]], &
		    c__1);
 
	}
    }
    return 0;

L40:
    if (*nc < 0) {
	goto L60;
    }
 
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	if (col[j] <= 0 || col[j] > *n) {
	    goto L100;
	}
 
    }
    if (*job == 1) {
	goto L45;
    }
    id1 = 1;
    d1[id1] = 1;
    i__1 = *nc;
    for (j = 1; j <= i__1; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++id1;
	    d1[id1] = d1[id1 - 1] + d__[id + i__] - d__[id + i__ - 1];
 
	}
    }
    if (*job == 0) {
	return 0;
    }
L45:
    id1 = 1;
    i__2 = *nc;
    for (j = 1; j <= i__2; ++j) {
	id = *m * (col[j] - 1) + 1;
	i__1 = d__[id + *m] - d__[id];
	icopy_(&i__1, &mp[d__[id]], &c__1, &mp1[d1[id1]], &c__1);
	id1 += *m;
 
    }
    return 0;

L50:
 
    i__2 = *nr;
    for (i__ = 1; i__ <= i__2; ++i__) {
	if (row[i__] <= 0 || row[i__] > *m) {
	    goto L100;
	}
 
    }
    if (*job == 1) {
	goto L55;
    }
    id1 = 1;
    d1[1] = 1;
    id = 1 - *m;
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	id += *m;
	i__1 = *nr;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    ++id1;
	    d1[id1] = d1[id1 - 1] + d__[id + row[i__]] - d__[id + row[i__] - 
		    1];
 
	}
    }
    if (*job == 0) {
	return 0;
    }
L55:
    id1 = 1;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	id = (j - 1) * *m;
	i__2 = *nr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    idi = id + row[i__];
	    i__3 = d__[idi + 1] - d__[idi];
	    icopy_(&i__3, &mp[d__[idi]], &c__1, &mp1[d1[id1]], &c__1);
	    ++id1;
 
	}
    }
    return 0;

L60:
 
    if (*job == 1) {
	goto L65;
    }
    i__2 = *m * *n + 1;
    for (i__ = 1; i__ <= i__2; ++i__) {
	d1[i__] = d__[i__];
 
    }
    if (*job == 0) {
	return 0;
    }
L65:
    i__2 = d__[*m * *n + 1] - 1;
    icopy_(&i__2, &mp[1], &c__1, &mp1[1], &c__1);
    return 0;
L100:
    *ierr = 1;
    return 0;
}  

 
  int impins_(mat1, dep1, lig1, col1, mat2, dep2, lig2, col2, 
	matr, depr, ligr, colr)
integer *mat1, *dep1, *lig1, *col1, *mat2, *dep2, *lig2, *col2, *matr, *depr, 
	*ligr, *colr;
{
     
    integer i__1, i__2;

     
    static integer i__, j, l;
    extern   int icopy_();
    static integer l1, l2, kr, lr;

 

 
 
 
 

 

 
 

 

 

 
 

 

 
 

 
 


 

 
 

 
 


 

     
    --depr;
    --matr;
    --dep2;
    --mat2;
    --dep1;
    --mat1;

     
    depr[1] = 1;
    kr = 1;

    i__1 = *colr;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *ligr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++kr;
	    lr = depr[kr];
	    if (lr < 0) {
		goto L11;
	    } else if (lr == 0) {
		goto L12;
	    } else {
		goto L13;
	    }
L11:
	    l2 = -lr;
	    l = dep2[l2 + 1] - dep2[l2];
	    icopy_(&l, &mat2[dep2[l2]], &c__1, &matr[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;
	    goto L20;
L12:
	    matr[depr[kr - 1]] = 40;
	    depr[kr] = depr[kr - 1] + 1;
	    goto L20;
L13:
	    l1 = lr;
	    l = dep1[l1 + 1] - dep1[l1];
	    icopy_(&l, &mat1[dep1[l1]], &c__1, &matr[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;

L20:
	    ;
	}
    }
    return 0;
}  

 
  int imptra_(pm1, d1, ld1, pm2, d2, m, n)
integer *pm1, *d1, *ld1, *pm2, *d2, *m, *n;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int icopy_();
    static integer i1, i2, l1, l2, n1;

 
 

 
 

 
 
 

 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
     
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1;
	    l2 = d2[i2];
	    icopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + n1;
 
	}
 
    }

    return 0;
}  

 
  int matra_(pm1, d1, ld1, pm2, d2, m, n)
integer *pm1, *d1, *ld1, *pm2, *d2, *m, *n;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int icopy_();
    static integer i1, i2, l1, l2, n1;

 
 

 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
     
    --d2;
    --pm2;
    --d1;
    --pm1;

     
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1;
	    l2 = d2[i2];
	    icopy_(&n1, &pm1[l1], &c__1, &pm2[l2], &c__1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + n1;
 
	}
 
    }

    return 0;
}  

 
  int mpdegr_(d__, nl, deg, m, n)
integer *d__, *nl, *deg, *m, *n;
{
     
    integer i__1, i__2, i__3, i__4;

     
    static integer i__, k, ip;

 
 

 
 
 
 
 
 
 
 
 

 
 
 

 
     
    --d__;

     
    *deg = 0;
    ip = -(*nl);
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	ip += *nl;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
 
	    i__3 = *deg, i__4 = d__[ip + i__ + 1] - d__[ip + i__] - 1;
	    *deg = (( i__3 ) >= ( i__4 ) ? ( i__3 ) : ( i__4 )) ;
 
	}
    }
    return 0;
}  

 
  int mpdiag_(d__, m, n, diag, dd, mr, nr)
integer *d__, *m, *n, *diag, *dd, *mr, *nr;
{
     
    integer i__1;

     
    static integer k, l, kk, mn;


     
    --dd;
    --d__;

     
    if (*n <= 0) {
	goto L20;
    }

 

    *nr = 1;
    mn = (( *m ) <= ( *n ) ? ( *m ) : ( *n )) ;
    k = -(*diag) + 1;
    if (*diag >= 0) {
	k = *diag * *m + 1;
    }
    *mr = *diag + *m;
    if (*diag + *m >= mn) {
	*mr = mn;
    }
    if (*diag >= *n - mn) {
	*mr = *n - *diag;
    }
    l = 0;
    if (*mr <= 0) {
	goto L11;
    }
    i__1 = *mr + 1;
    for (kk = 2; kk <= i__1; ++kk) {
	dd[kk] = k;
	l = l + d__[k + 1] - d__[k];
 
	k = k + *m + 1;
    }
L11:
    dd[1] = l;
    return 0;


 

L20:
    *mr = *m;
    *nr = *m;
    l = 0;
    if (*diag >= 0) {
	*nr += *diag;
    } else {
	*mr -= *diag;
    }
    i__1 = *mr * *nr + 1;
    for (k = 2; k <= i__1; ++k) {
 
	dd[k] = 0;
    }
    kk = 1 - *diag;
    if (*diag >= 0) {
	kk = *diag * *mr + 1;
    }
    i__1 = *m;
    for (k = 1; k <= i__1; ++k) {
	dd[kk + 1] = k;
	kk = kk + *mr + 1;
 
	l = d__[k + 1] - d__[k] + l;
    }
    dd[1] = l + *mr * *nr - *m;
    return 0;
}  

 
  int mpinsp_(dep1, lig1, col1, v1, d1, v2, d2, dep2, lig2, 
	col2, depr, ligr, colr, ierr)
integer *dep1, *lig1, *col1, *v1, *d1, *v2, *d2, *dep2, *lig2, *col2, *depr, *
	ligr, *colr, *ierr;
{
     
    integer i__1, i__2, i__3;

     
    static integer volr, i__, k1, k2, ir, jr, kr, id1, id2;

 

 
 
 

 

 
 

 

 
 

 

 

 

 

 

 
 

 
 
 

 
 
 

 
 


 
 
 

 
 


 


     
    --depr;
    --dep2;
    --v2;
    --v1;
    --dep1;

     
    *ierr = 0;
    volr = 0;
    if (*d1 == 0 || *d2 == 0) {
	return 0;
    }

 

    if (*d1 > 0 || *d2 > 0) {
	goto L10;
    }
    if (*lig1 != *lig2 || *col1 != *col2) {
	goto L50;
    }

    ir = *lig1 * *col1 + 1;
    i__1 = ir;
    for (i__ = 1; i__ <= i__1; ++i__) {
 
	depr[i__ + 1] = -i__;
    }
    volr = dep2[ir] - dep2[1];
    goto L999;

L10:
    if (*d1 < 0) {
	if ((( 1 ) >= ( *lig1 ) ? ( 1 ) : ( *lig1 ))  != *lig2) {
	    goto L50;
	}

 

	kr = 1;
	volr = 0;
	i__1 = *colr;
	for (jr = 1; jr <= i__1; ++jr) {
 
	    id2 = 0;
	    i__2 = *d2;
	    for (i__ = 1; i__ <= i__2; ++i__) {
 
		if (v2[i__] == jr) {
		    id2 = i__;
		}
	    }
	    if (id2 == 0) {
		goto L13;
	    }
 
	    k2 = *lig2 * (id2 - 1);
	    i__2 = *ligr;
	    for (ir = 1; ir <= i__2; ++ir) {
		++kr;
		depr[kr] = -(k2 + ir);
 
	    }
	    volr = volr + dep2[k2 + *ligr + 1] - dep2[k2 + 1];
	    goto L16;
 
L13:
	    if (jr <= *col1) {
 
		k1 = (jr - 1) * *lig1;
		i__2 = *ligr;
		for (ir = 1; ir <= i__2; ++ir) {
		    ++kr;
 
		    depr[kr] = k1 + ir;
		}
		volr = volr + dep1[k1 + *ligr + 1] - dep1[k1 + 1];
		goto L16;
	    }
 
	    i__2 = *ligr;
	    for (ir = 1; ir <= i__2; ++ir) {
		++kr;
 
		depr[kr] = 0;
	    }
	    volr += *ligr;
L16:
	    ;
	}
	goto L999;
    }

    if (*d2 < 0) {
	if (*col1 != (( 1 ) >= ( *col2 ) ? ( 1 ) : ( *col2 )) ) {
	    goto L50;
	}

 

	i__1 = *ligr;
	for (ir = 1; ir <= i__1; ++ir) {
	    kr = ir + 1 - *ligr;
 
	    id1 = 0;
	    i__2 = *d1;
	    for (i__ = 1; i__ <= i__2; ++i__) {
 
		if (v1[i__] == ir) {
		    id1 = i__;
		}
	    }
	    if (id1 == 0) {
		goto L23;
	    }
 
	    k2 = id1 - *lig2;
	    i__2 = *colr;
	    for (jr = 1; jr <= i__2; ++jr) {
		kr += *ligr;
		k2 += *lig2;
		depr[kr] = -k2;
		volr = volr + dep2[k2 + 1] - dep2[k2];
 
	    }
	    goto L26;
 
L23:
	    if (ir <= *lig1) {
 
		k1 = ir - *lig1;
		i__2 = *colr;
		for (jr = 1; jr <= i__2; ++jr) {
		    kr += *ligr;
		    k1 += *lig1;
		    volr = volr + dep1[k1 + 1] - dep1[k1];
 
		    depr[kr] = k1;
		}
		goto L26;
	    }
 
	    i__2 = *colr;
	    for (jr = 1; jr <= i__2; ++jr) {
		kr += *ligr;
 
		depr[kr] = 0;
	    }
	    volr += *colr;
L26:
	    ;
	}
	goto L999;
    }

 

    kr = 2;
    i__1 = *colr;
    for (jr = 1; jr <= i__1; ++jr) {
 
	id2 = 0;
	i__2 = *d2;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    if (v2[i__] == jr) {
		id2 = i__;
	    }
 
	}

	if (id2 == 0) {
	    goto L35;
	}

	i__2 = *ligr;
	for (ir = 1; ir <= i__2; ++ir) {
 
	    id1 = 0;
	    i__3 = *d1;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		if (v1[i__] == ir) {
		    id1 = i__;
		}
 
	    }

	    if (id1 == 0) {
		goto L32;
	    }

	    k2 = id1 + *lig2 * (id2 - 1);
	    depr[kr] = -k2;
	    ++kr;
	    volr = volr + dep2[k2 + 1] - dep2[k2];
	    goto L34;

L32:
	    if (ir > *lig1 || jr > *col1) {
		goto L33;
	    }
	    k1 = ir + *lig1 * (jr - 1);
	    depr[kr] = k1;
	    ++kr;
	    volr = volr + dep1[k1 + 1] - dep1[k1];
	    goto L34;

L33:
	    depr[kr] = 0;
	    ++kr;
	    ++volr;
L34:
	    ;
	}
	goto L40;
 
 
L35:
	if (jr > *col1) {
	    goto L38;
	}
	k1 = (jr - 1) * *lig1;
	i__2 = *lig1;
	for (ir = 1; ir <= i__2; ++ir) {
	    depr[kr] = k1 + ir;
 
	    ++kr;
	}
	volr = volr + dep1[k1 + *lig1 + 1] - dep1[k1 + 1];
	if (*lig1 >= *ligr) {
	    goto L40;
	}
	i__2 = *ligr;
	for (ir = *lig1 + 1; ir <= i__2; ++ir) {
	    depr[kr] = 0;
 
	    ++kr;
	}
	volr = volr + *ligr - *lig1;
	goto L40;
L38:
	i__2 = *ligr;
	for (ir = 1; ir <= i__2; ++ir) {
	    depr[kr] = 0;
 
	    ++kr;
	}
	volr += *ligr;
L40:
	;
    }

L999:
    depr[1] = volr;
    return 0;
L50:
    *ierr = 1;
    return 0;
}  

 
  int mptri_(d__, m, n, diag, dd, job)
integer *d__, *m, *n, *diag, *dd, *job;
{
     
    integer i__1;

     
    extern   int iset_();
    static integer i__, j, l, ll, nn, ls;



     
    --dd;
    --d__;

     
    i__1 = *m * *n + 1;
    for (i__ = 2; i__ <= i__1; ++i__) {
 
	dd[i__] = i__ - 1;
    }

    if (*job == 0) {
	goto L15;
    }
 
    if (*diag <= 0) {
	goto L11;
    }
    i__1 = *m * *diag;
    iset_(&i__1, &c__0, &dd[2], &c__1);
    ls = *m * *diag + 2;
    nn = *n - *diag;
    ll = *m - 1;
    goto L12;
L11:
    ls = 2 - *diag;
    nn = *n;
    ll = *m - 1 + *diag;
L12:
    i__1 = nn;
    for (j = 1; j <= i__1; ++j) {
	if (ll <= 0) {
	    goto L20;
	}
	iset_(&ll, &c__0, &dd[ls + 1], &c__1);
	--ll;
	ls = ls + *m + 1;
 
    }
    goto L20;

 
L15:
    nn = *n;
    if (*diag < 0) {
	goto L16;
    }
    ls = *m * (*diag + 1) + 1;
    nn = *n - *diag - 1;
    ll = 1;
    goto L17;
L16:
    ls = 1;
    ll = -(*diag);
    nn = *n;
L17:
    i__1 = nn;
    for (j = 1; j <= i__1; ++j) {
	if (ll > *m) {
	    ll = *m;
	}
	iset_(&ll, &c__0, &dd[ls + 1], &c__1);
	ls += *m;
	++ll;
 
    }

 
L20:
    l = 0;
    i__1 = *m * *n + 1;
    for (i__ = 2; i__ <= i__1; ++i__) {
	if (dd[i__] == 0) {
	    ++l;
	} else {
	    l = l + d__[dd[i__] + 1] - d__[dd[i__]];
	}
 
    }
    dd[1] = l;
    return 0;
}  

  int recbez_(p1, n1, p2, n2, best, ipb, w, err)
doublereal *p1;
integer *n1;
doublereal *p2;
integer *n2;
doublereal *best;
integer *ipb;
doublereal *w, *err;
{
     
    integer i__1;

     
    extern   int dset_();
    static integer l, ifree;
    extern   int dcopy_();
    static integer n0, ia, la, na, n02;
    extern doublereal dlamch_();
    static integer iu, np, iw, lu, nu;
    extern   int bezstp_();
    static integer nn1, nn2;

 
 

 
 
 
 
 
 
 

 

 
 
 

 
 

 
 
 
 
 
 

 
 
 
 
 
 
 
 


     
    --p1;
    --p2;
    --best;
    --ipb;
    --w;

     
    *err = dlamch_("o", 1L);
    ia = 1;
    nn1 = *n1;
    nn2 = *n2;

 

    ++nn1;
L1:
    --nn1;
    if (nn1 < 0) {
	goto L30;
    }
    if (p1[nn1 + 1] == 0.) {
	goto L1;
    }

    ++nn2;
L2:
    --nn2;
    if (nn2 < 0) {
	goto L30;
    }
    if (p2[nn2 + 1] == 0.) {
	goto L2;
    }

    n0 = (( nn1 ) >= ( nn2 ) ? ( nn1 ) : ( nn2 ))  + 1;
    n02 = n0 * (n0 + 1);
    na = n0 + 1;
    dset_(&n02, &c_b61, &w[ia], &c__1);
    iu = ia + n02;
    nu = n0 + 1;
    i__1 = n02 << 1;
    dset_(&i__1, &c_b61, &w[iu], &c__1);
    iw = iu + (n02 << 1);
    ifree = iw + n0 * 7;

    la = ia + na - 1;
    lu = iu + nu - 1 + (n0 << 1) * nu;

    i__1 = nn1 + 1;
    dcopy_(&i__1, &p1[1], &c__1, &w[la - 1], &na);
    i__1 = nn2 + 1;
    dcopy_(&i__1, &p2[1], &c__1, &w[la], &na);
    i__1 = nu + 1;
    dset_(&c__2, &c_b89, &w[lu - 1 - (nu << 1)], &i__1);

    i__1 = n0;
    for (l = 1; l <= i__1; ++l) {
	--la;
	lu = lu - 1 - (nu << 1);
 

 

	bezstp_(&p1[1], &nn1, &p2[1], &nn2, &w[la], &na, &w[lu], &nu, &l, &w[
		la - 1 + na], &w[lu - 1 - (nu << 1)], &w[iw], &best[1], &ipb[
		1], err);
 
    }
    return 0;
L30:
    *err = 0.;
    ipb[1] = 1;
    if ((( nn1 ) <= ( nn2 ) ? ( nn1 ) : ( nn2 ))  == 0) {
	goto L70;
    }
    if ((i__1 = nn1 - nn2) < 0) {
	goto L40;
    } else if (i__1 == 0) {
	goto L50;
    } else {
	goto L60;
    }
L40:
 
    np = nn2;
    i__1 = nn2 + 1;
    dcopy_(&i__1, &p2[1], &c__1, &best[1], &c__1);
    ipb[2] = ipb[1] + nn2 + 1;
    best[ipb[2]] = 0.;
    ipb[3] = ipb[2] + 1;
    best[ipb[3]] = 1.;
    ipb[4] = ipb[3] + 1;
    best[ipb[4]] = 1.;
    ipb[5] = ipb[4] + 1;
    best[ipb[5]] = 0.;
    ipb[6] = ipb[5] + 1;
    return 0;
L50:
 
    np = 0;
    best[1] = 0.;
    ipb[2] = ipb[1] + 1;
    best[ipb[2]] = 1.;
    ipb[3] = ipb[2] + 1;
    best[ipb[3]] = 0.;
    ipb[4] = ipb[3] + 1;
    best[ipb[4]] = 0.;
    ipb[5] = ipb[4] + 1;
    best[ipb[5]] = 1.;
    ipb[6] = ipb[5] + 1;
    return 0;
L60:
 
    np = nn1;
    i__1 = nn1 + 1;
    dcopy_(&i__1, &p1[1], &c__1, &best[1], &c__1);
    ipb[2] = ipb[1] + nn1 + 1;
    best[ipb[2]] = 1.;
    ipb[3] = ipb[2] + 1;
    best[ipb[3]] = 0.;
    ipb[4] = ipb[3] + 1;
    best[ipb[4]] = 0.;
    ipb[5] = ipb[4] + 1;
    best[ipb[5]] = 1.;
    ipb[6] = ipb[5] + 1;
    return 0;

L70:
    best[1] = 1.;
    ipb[2] = 2;
    if ((i__1 = nn1 - nn2) < 0) {
	goto L90;
    } else if (i__1 == 0) {
	goto L95;
    } else {
	goto L100;
    }
L90:
 
    best[ipb[2]] = 1. / p1[1];
    ipb[3] = ipb[2] + 1;
    best[ipb[3]] = 0.;
    ipb[4] = ipb[3] + 1;
    i__1 = nn2 + 1;
    dcopy_(&i__1, &p2[1], &c__1, &best[ipb[4]], &c__1);
    ipb[5] = ipb[4] + nn2 + 1;
    best[ipb[5]] = -p1[1];
    ipb[6] = ipb[5] + 1;
    return 0;
L95:
 
    if ((( p1[1] ) >= 0 ? ( p1[1] ) : -( p1[1] ))  > (( p2[1] ) >= 0 ? ( p2[1] ) : -( p2[1] )) ) {
	goto L90;
    }

L100:
 
    best[ipb[2]] = 0.;
    ipb[3] = ipb[2] + 1;
    best[ipb[3]] = 1. / p2[1];
    ipb[4] = ipb[3] + 1;
    best[ipb[4]] = -p2[1];
    ipb[5] = ipb[4] + 1;
    i__1 = nn1 + 1;
    dcopy_(&i__1, &p1[1], &c__1, &best[ipb[5]], &c__1);
    ipb[6] = ipb[5] + nn1 + 1;
    return 0;

}  

 
  int residu_(p, np, a, na, b, nb, v, tol, ierr)
doublereal *p;
integer *np;
doublereal *a;
integer *na;
doublereal *b;
integer *nb;
doublereal *v, *tol;
integer *ierr;
{
     
    integer i__1, i__2;

     
    static integer k;
    static doublereal r__, b1;
    extern   int idegre_(), dpodiv_();
    static integer nbb, nit, npp;

 
 
 
 
 
 

 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

     
    --b;
    --a;
    --p;

     
    *v = 0.;
    *ierr = 0;
    npp = *np;
    idegre_(&a[1], na, na);
    idegre_(&b[1], nb, nb);
    if (*na == 0) {
	return 0;
    }

 
    if (*nb == 0) {
	b1 = b[1];
	if (b1 == 0.) {
	    *ierr = 1;
	    return 0;
	}
	if (npp >= *na - 1) {
	    *v = p[*na] / a[*na + 1] / b1;
	    return 0;
	} else {
	    *v = 0.;
	    return 0;
	}
    }

 

    if (*na <= *np) {
 
	dpodiv_(&p[1], &a[1], np, na);
	i__1 = *na - 1;
	idegre_(&p[1], &i__1, np);
    }
    if (*na <= *nb) {
 
	dpodiv_(&b[1], &a[1], nb, na);
	i__1 = *na - 1;
	idegre_(&b[1], &i__1, nb);
    }
 
 
 
    if (*na == 1) {
	b1 = b[1];
	if ((( b1 ) >= 0 ? ( b1 ) : -( b1 ))  <= *tol) {
	    *ierr = 1;
	    return 0;
	}
	*v = p[*na] / a[*na + 1] / b1;
	return 0;
    }

 
 
    i__2 = *na - 1;
    i__1 = (( i__2 ) <= ( *nb ) ? ( i__2 ) : ( *nb )) ;
    idegre_(&b[1], &i__1, nb);
    if (*nb == 0) {
	b1 = b[1];
	if ((( b1 ) >= 0 ? ( b1 ) : -( b1 ))  <= *tol) {
	    *ierr = 1;
	    return 0;
	}
	if (npp >= *na - 1) {
	    *v = p[*na] / a[*na + 1] / b1;
	    return 0;
	} else {
	    *v = 0.;
	    return 0;
	}
    }
 
    nit = 0;
L20:
    if (nit >= 1) {
	*na = nbb;
    }
    ++nit;
    nbb = *nb;
 
 

    dpodiv_(&a[1], &b[1], na, nb);
    i__1 = *nb - 1;
    idegre_(&a[1], &i__1, na);
    dpodiv_(&p[1], &b[1], np, nb);
    i__1 = *nb - 1;
    idegre_(&p[1], &i__1, np);
 
    i__1 = *nb + 1;
    for (k = 1; k <= i__1; ++k) {
	r__ = b[k];
	b[k] = -a[k];
	a[k] = r__;
 
    }

 

    idegre_(&b[1], na, nb);
    if (*nb == 0) {
	b1 = b[1];
	if ((( b1 ) >= 0 ? ( b1 ) : -( b1 ))  <= *tol) {
	    *ierr = 1;
	    *v = 0.;
	    return 0;
	}
	*v = p[nbb] / a[nbb + 1] / b1;
	return 0;
    }
 
    goto L20;
}  

 
  int sfact1_(b, n, w, maxit, ierr)
doublereal *b;
integer *n;
doublereal *w;
integer *maxit, *ierr;
{
     
    integer i__1, i__2, i__3;
    doublereal d__1;

     
    double sqrt(), d_lg10();
    integer i_dnnt();

     
    static integer leta;
    static doublereal best, temp;
    static integer i__, j, k;
    static doublereal s;
    static integer lbold, lomeg, lsave;
    extern   int dcopy_();
    static doublereal a0, b0, b00;
    static integer lb, lambda;
    extern doublereal dlamch_();
    static integer lalpha;
    static doublereal eps;
    static integer lro;

 
 
 
 
 

 
 

 
 
 
 
 
 
 
 
 
 

 
 
 
 
 
 

     
    --b;
    --w;

     
    eps = dlamch_("p", 1L) * 10.;

    lb = *n + 1;
    *ierr = 0;

    lomeg = 1;
    lalpha = lomeg + lb;
    lro = lalpha + lb;
    leta = lro + lb;
    lbold = leta + lb;
    lambda = lbold + lb;
    lsave = lambda + lb;

    dcopy_(&lb, &b[1], &c_n1, &w[lbold], &c__1);
    dcopy_(&lb, &w[lbold], &c__1, &b[1], &c__1);
    b00 = w[lbold];
    if (b00 <= 0.) {
	goto L91;
    }
    b0 = sqrt(b00);
    i__1 = lb;
    for (j = 1; j <= i__1; ++j) {
	w[lalpha - 1 + j] = b[j] / b0;
 
    }

    i__1 = *maxit;
    for (i__ = 1; i__ <= i__1; ++i__) {

	dcopy_(&lb, &w[lbold], &c__1, &b[1], &c__1);
	dcopy_(&lb, &w[lalpha], &c__1, &w[lomeg], &c__1);
 
	i__2 = lb - 1;
	for (k = 1; k <= i__2; ++k) {
	    i__3 = lb - k + 1;
	    dcopy_(&i__3, &w[lalpha], &c_n1, &w[lro], &c__1);
	    w[lambda + k - 1] = w[lalpha + lb - k] / w[lro + lb - k];
	    i__3 = lb - k;
	    for (j = 1; j <= i__3; ++j) {
		w[lalpha - 1 + j] -= w[lambda + k - 1] * w[lro + j - 1];
 
	    }
	    a0 = w[lalpha];
 
	    w[leta + lb - k] = b[lb - k + 1] * 2. / a0;
	    if (k < lb - 1) {
		i__3 = lb - k;
		for (j = 2; j <= i__3; ++j) {
		    b[j] -= w[leta + lb - k] * .5 * w[lalpha + lb - k - j + 1]
			    ;
 
		}
	    }
 
	}
	w[leta] = b[1] / w[lalpha];
 
	for (k = lb - 1; k >= 1; --k) {
	    i__2 = lb - k + 1;
	    dcopy_(&i__2, &w[leta], &c_n1, &b[1], &c__1);
	    i__2 = lb - k + 1;
	    for (j = 1; j <= i__2; ++j) {
		w[leta + j - 1] -= w[lambda + k - 1] * b[j];
 
	    }
 
	}
	s = 0.;
	i__2 = lb;
	for (j = 1; j <= i__2; ++j) {
	    w[lalpha - 1 + j] = (w[leta + j - 1] + w[lomeg + j - 1]) * .5;
	    s += w[lalpha - 1 + j] * w[lalpha - 1 + j];
 
	}

 
 
 
 
 
 
 
	temp = (d__1 = s - b00, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) / b00;
	if (temp <= eps) {
	    goto L50;
	}
	if (i__ == 1) {
	    best = temp;
	}
	if (temp < best) {
	    dcopy_(&lb, &w[lalpha], &c__1, &w[lsave], &c__1);
	    best = temp;
	}
 
    }
    goto L90;

L50:
    i__1 = lb;
    for (i__ = 1; i__ <= i__1; ++i__) {
	b[i__] = w[lalpha - 1 + i__];
 
    }
    return 0;

 

L90:
    if (best <= .001) {
	dcopy_(&lb, &w[lsave], &c__1, &b[1], &c__1);
	d__1 = d_lg10(&best);
	*ierr = i_dnnt(&d__1);
    } else {
 
	*ierr = 1;
    }
    return 0;
L91:
 
    *ierr = 2;
    return 0;
}  

 
  int sfact2_(b, l, n, matg, maxit, ierr)
doublereal *b;
integer *l, *n;
doublereal *matg;
integer *maxit, *ierr;
{
     
    integer b_dim1, b_offset, i__1, i__2, i__3, i__4;
    doublereal d__1;

     
    double sqrt();

     
    static integer iter, j, k, p, q, r__;
    static doublereal sigma;
    static integer k0, j1, j2, jj, q22, kk, id0;
    static doublereal tr1, tr2, acu;
    static integer nel;


 
 
 
 

 
 
 
 

 
 
 
 
 
 
 

 
 

 

 

 
 

 
 
 
 
 

 

 
 
 
 

 

 
 
 
 

 




 
 
 

     
    b_dim1 = *l;
    b_offset = b_dim1 + 1;
    b -= b_offset;
    --matg;

     
    p = *n * *l;
    q = p + *l;
    q22 = (q << 1) + 2;

    nel = q * (q + 1) / 2;
    i__1 = nel;
    for (j = 1; j <= i__1; ++j) {
 
	matg[j] = 0.;
    }
    i__1 = q;
    for (j = p + 1; j <= i__1; ++j) {
	i__2 = q;
	for (r__ = j; r__ <= i__2; ++r__) {
 
	    matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = b[r__ - p + (j - p) 
		    * b_dim1];
	}
    }

    id0 = p + 1;
    k0 = p;
    iter = 0;
    j = p;

 
    goto L20;

L10:

 

    i__2 = p;
    for (j = id0; j <= i__2; ++j) {
	j1 = (j - 1) / *l;
	j2 = j - j1 * *l;
	jj = (*n - j1) * *l + j2;
	if (matg[j - j + 1 + (q22 - j) * (j - 1) / 2] == 0.) {
	    goto L60;
	}
	i__1 = q;
	for (r__ = p + 1; r__ <= i__1; ++r__) {
	    sigma = 0.;
	    if (j == id0) {
		goto L12;
	    }
	    i__3 = j - 1;
	    for (k = id0; k <= i__3; ++k) {
		sigma += matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[r__ 
			- k + 1 + (q22 - k) * (k - 1) / 2];
 
	    }
L12:
	    matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = (b[r__ - p + jj * 
		    b_dim1] - sigma) / matg[j - j + 1 + (q22 - j) * (j - 1) / 
		    2];
 
	}
 
    }

 

    i__2 = q;
    for (j = p + 1; j <= i__2; ++j) {
	i__1 = q;
	for (r__ = j; r__ <= i__1; ++r__) {
	    sigma = 0.;
	    i__3 = p;
	    for (k = id0; k <= i__3; ++k) {
 
		sigma += matg[r__ - k + 1 + (q22 - k) * (k - 1) / 2] * matg[j 
			- k + 1 + (q22 - k) * (k - 1) / 2];
	    }
	    matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = b[r__ - p + (j - p) 
		    * b_dim1] - sigma;
 
	}
 
    }

L20:

 

    i__2 = q;
    for (j = p + 1; j <= i__2; ++j) {
	sigma = matg[j - j + 1 + (q22 - j) * (j - 1) / 2];
	if (j == p + 1) {
	    goto L22;
	}
	i__1 = j - 1;
	for (k = p + 1; k <= i__1; ++k) {
	    sigma -= matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[j - k + 
		    1 + (q22 - k) * (k - 1) / 2];
 
	}
L22:
	if (sigma <= 0.) {
	    goto L60;
	}
	matg[j - j + 1 + (q22 - j) * (j - 1) / 2] = sqrt(sigma);
	if (j == q) {
	    goto L26;
	}

	i__1 = q;
	for (r__ = j + 1; r__ <= i__1; ++r__) {
	    sigma = matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2];
	    if (j == p + 1) {
		goto L24;
	    }
	    i__3 = j - 1;
	    for (k = p + 1; k <= i__3; ++k) {
		sigma -= matg[j - k + 1 + (q22 - k) * (k - 1) / 2] * matg[r__ 
			- k + 1 + (q22 - k) * (k - 1) / 2];
 
	    }
L24:
	    matg[r__ - j + 1 + (q22 - j) * (j - 1) / 2] = sigma / matg[j - j 
		    + 1 + (q22 - j) * (j - 1) / 2];
 
	}
L26:
	;
    }

    if (*n == 0) {
	goto L50;
    }

 

    tr2 = 0.;
    i__2 = q;
    for (jj = p + 1; jj <= i__2; ++jj) {
	tr2 += matg[jj - jj + 1 + (q22 - jj) * (jj - 1) / 2];
 
    }

 

    if (iter == 1) {
	goto L40;
    }
    acu = (d__1 = tr1 - tr2, (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
    if (acu + (( tr2 ) >= 0 ? ( tr2 ) : -( tr2 ))  <= (( tr2 ) >= 0 ? ( tr2 ) : -( tr2 )) ) {
	goto L50;
    }
    if (iter >= *maxit) {
	goto L50;
    }

 

L40:
 
    i__2 = id0 - *l;
    id0 = (( i__2 ) >= ( 1 ) ? ( i__2 ) : ( 1 )) ;
    i__2 = p;
    for (jj = id0; jj <= i__2; ++jj) {
	i__1 = jj;
	for (kk = id0; kk <= i__1; ++kk) {
	    i__3 = jj + *l;
	    i__4 = kk + *l;
	    matg[jj - kk + 1 + (q22 - kk) * (kk - 1) / 2] = matg[i__3 - i__4 
		    + 1 + (q22 - i__4) * (i__4 - 1) / 2];
 
	}
    }
    tr1 = tr2;

    ++iter;
    goto L10;

L50:

 

    i__1 = *l;
    for (r__ = 1; r__ <= i__1; ++r__) {
	i__2 = *l;
	for (j = r__; j <= i__2; ++j) {
	    b[r__ + j * b_dim1] = 0.;
 
	    i__3 = p + j;
	    i__4 = p + r__;
	    b[j + r__ * b_dim1] = matg[i__3 - i__4 + 1 + (q22 - i__4) * (i__4 
		    - 1) / 2];
	}
	if (*n == 0) {
	    goto L53;
	}
	i__3 = q;
	for (j = *l + 1; j <= i__3; ++j) {
	    j1 = (j - 1) / *l;
	    j2 = j - j1 * *l;
	    jj = (*n - j1) * *l + j2;
 
	    i__4 = p + r__;
	    b[r__ + j * b_dim1] = matg[i__4 - jj + 1 + (q22 - jj) * (jj - 1) /
		     2];
	}
L53:
	;
    }
    *ierr = 0;
    if (iter >= *maxit) {
	*ierr = -1;
    }
    return 0;
L60:
    *ierr = 1;
    return 0;

}  

  int strdsp_(mat, d__, lig, col, ll, lunit, iw, cw, cw_len)
integer *mat, *d__, *lig, *col, *ll, *lunit, *iw;
char *cw;
ftnlen cw_len;
{
     

    static integer nind = 5;

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3, i__4[2], i__5[4], i__6, i__7;
    char ch__1[15], ch__2[24];
    icilist ici__1;

     
    integer s_wsfi(), do_fio(), e_wsfi();
      int s_cat(), s_copy();

     
    static integer lcol, i__, k, l, lbloc, nbloc, lines, c1, k0, k1, k2, l1, 
	    l0;
    extern   int cvstr_();
    static integer ib;
    static char dl[1];
    static integer il, io, lp, sk, sl, np, indent;
    extern   int basout_();
    static integer ll1, np1, ldg, lgh;

 

 
 

 

 

 

 

 

 
 

 
 

 

 

 

 
 

 

 

 
 
 


     
    --iw;
    --d__;
    --mat;

     

    *(unsigned char *)dl = ' ';
    if (*lig * *col > 1) {
	*(unsigned char *)dl = '!';
    }

    lcol = 1;
    lines = 0;
    lbloc = lcol + *col - 1;
    nbloc = 1;
    iw[lbloc + nbloc] = *col;
    sk = 0;

 
    if (*col == 0 || *lig == 0) {
	return 0;
    }

    l = 1;
    k0 = 1;
    i__1 = *col;
    for (k = 1; k <= i__1; ++k) {
	sl = 0;
	iw[k] = 0;
	i__2 = *lig;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    lgh = d__[l + 1] - d__[l] + 2;
 
	    i__3 = iw[k];
	    iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ;
	    sl = sl + lgh / (*ll - 2) + 1;
	    ++l;
 
	}
	sk += iw[k];
	if (sk > *ll - 2) {
	    if (k == k0) {
		iw[lbloc + nbloc] = k;
		sk = 0;
		k0 = k + 1;
	    } else {
		iw[lbloc + nbloc] = k - 1;
		sk = iw[k];
		k0 = k;
	    }
	    ++nbloc;
	    iw[lbloc + nbloc] = *col;
 
	}
 
    }
    nbloc = (( nbloc ) <= ( *col ) ? ( nbloc ) : ( *col )) ;


    k1 = 1;
    i__1 = nbloc;
    for (ib = 1; ib <= i__1; ++ib) {
	k2 = iw[lbloc + ib];
	ll1 = 0;
	if (nbloc != 1) {
	    if (k1 == k2) {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 4;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__4[0] = 11, a__1[0] = "    column ";
		i__4[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__4, &c__2, 15L);
		basout_(&io, lunit, ch__1, 15L);
	    } else {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 8;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(2i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__5[0] = 12, a__2[0] = "    columns ";
		i__5[1] = 4, a__2[1] = cw;
		i__5[2] = 4, a__2[2] = " to ";
		i__5[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__5, &c__4, 24L);
		basout_(&io, lunit, ch__2, 24L);
		basout_(&io, lunit, " ", 1L);
	    }
	    if (io == -1) {
		goto L99;
	    }
	}

	*(unsigned char *)cw = *(unsigned char *)dl;
	c1 = 2;

	i__2 = *lig;
	for (l = 1; l <= i__2; ++l) {
	    l1 = c1;
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		l0 = l1;
		ldg = (k - 1) * *lig + l;
		lp = d__[ldg];
		np = d__[ldg + 1] - d__[ldg];

		ll1 = 0;
		indent = 0;
L40:
 
		i__6 = np, i__7 = *ll - 2 - indent;
		np1 = (( i__6 ) <= ( i__7 ) ? ( i__6 ) : ( i__7 )) ;
		cvstr_(&np1, &mat[lp], cw + (l1 - 1), &c__1, l1 + np1 - 1 - (
			l1 - 1));
		l1 += np1;
		if (np1 != np) {
		    ll1 = *ll;
		    if (l1 <= *ll - 1) {
			s_copy(cw + (l1 - 1), " ", *ll - 1 - (l1 - 1), 1L);
		    }
		    *(unsigned char *)&cw[*ll - 1] = *(unsigned char *)dl;
		    i__6 = c1 - 2;
		    basout_(&io, lunit, cw + i__6, *ll - i__6);
		    if (io == -1) {
			goto L99;
		    }
		    s_copy(cw + (c1 - 1), " ", c1 + nind - 1 - (c1 - 1), 1L);
		    l1 = c1 + nind;
		    indent = nind;
		    lp += np1;
		    np -= np1;
		    if (np > 0) {
			goto L40;
		    }
		}
 
		i__6 = iw[k], i__7 = *ll - 2;
		il = (( i__6 ) <= ( i__7 ) ? ( i__6 ) : ( i__7 )) ;
		if (l0 + il >= l1) {
		    s_copy(cw + (l1 - 1), " ", l0 + il - (l1 - 1), 1L);
		    l1 = l0 + il;
		}
 
	    }
	    if (ll1 == *ll) {
		if (l1 <= *ll) {
		    s_copy(cw + (l1 - 1), " ", *ll - (l1 - 1), 1L);
		    l1 = *ll;
		}
	    }
	    *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
	    i__3 = c1 - 2;
	    basout_(&io, lunit, cw + i__3, l1 - i__3);
	    if (io == -1) {
		goto L99;
	    }
	    if (l != *lig) {
		s_copy(cw + (c1 - 1), "  ", l1 - 1 - (c1 - 1), 2L);
		i__3 = c1 - 2;
		basout_(&io, lunit, cw + i__3, l1 - i__3);
		if (io == -1) {
		    goto L99;
		}
	    }
 
	}
	k1 = k2 + 1;
 
    }

L99:
    return 0;
 
 
 
}  

 
  int wdmpad_(pm1r, pm1i, d1, l1, pm2r, d2, l2, pm3r, pm3i, d3,
	 m, n)
doublereal *pm1r, *pm1i;
integer *d1, *l1;
doublereal *pm2r;
integer *d2, *l2;
doublereal *pm3r, *pm3i;
integer *d3, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k, i1, i2, k1, n1, n2, n3, k3, k2, mn;

 
 
 
 
 
 

 
 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 


     
    --d3;
    --pm3i;
    --pm3r;
    --d2;
    --pm2r;
    --d1;
    --pm1i;
    --pm1r;

     
    mn = *m * *n;

    d3[1] = 1;
    i1 = -(*l1);
    i2 = -(*l2);
    k3 = 0;
 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *l1;
	i2 += *l2;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[i1 + i__] - 1;
	    k2 = d2[i2 + i__] - 1;
	    n1 = d1[i1 + i__ + 1] - d1[i1 + i__];
	    n2 = d2[i2 + i__ + 1] - d2[i2 + i__];
	    if (n1 > n2) {
		goto L15;
	    }

 

	    i__3 = n1;
	    for (k = 1; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k];
		pm3i[k3 + k] = pm1i[k1 + k];
 
	    }
	    if (n1 == n2) {
		goto L14;
	    }
	    n3 = n1 + 1;
	    i__3 = n2;
	    for (k = n3; k <= i__3; ++k) {
		pm3r[k3 + k] = pm2r[k2 + k];
 
		pm3i[k3 + k] = 0.;
	    }
L14:
	    n3 = n2;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;
	    goto L18;

 

L15:
	    i__3 = n2;
	    for (k = 1; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k];
 
		pm3i[k3 + k] = pm1i[k1 + k];
	    }
	    n3 = n2 + 1;
	    i__3 = n1;
	    for (k = n3; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k];
 
		pm3i[k3 + k] = pm1i[k1 + k];
	    }
	    n3 = n1;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;

L18:
	    k1 += n1;
	    k2 += n2;
	    k3 += n3;
 
	}
    }
    return 0;
}  

 
  int wdmpmu_(mp1r, mp1i, d1, nl1, mp2r, d2, nl2, mp3r, mp3i, 
	d3, l, m, n)
doublereal *mp1r, *mp1i;
integer *d1, *nl1;
doublereal *mp2r;
integer *d2, *nl2;
doublereal *mp3r, *mp3i;
integer *d3, *l, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k;
    extern   int dpmul_();
    static integer k1, k2, k3, p1, p2, p3, kk;

 
 
 

 

 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
 
 

 
 
 

 
 
 

 
 
 


 




     
    --d3;
    --mp3i;
    --mp3r;
    --d2;
    --mp2r;
    --d1;
    --mp1i;
    --mp1r;

     
    d3[1] = 1;
    if (*l == 0 || *m == 0 || *n == 0) {
	goto L500;
    }

    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    p1 = i__ - *nl1;
	    i__3 = *m;
	    for (k = 1; k <= i__3; ++k) {
		p1 += *nl1;
		k2 = d2[p2 + k + 1] - d2[p2 + k] - 1;
		k1 = d1[p1 + 1] - d1[p1] - 1;
		kk = k3;
		dpmul_(&mp1r[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3r[d3[
			p3 + i__]], &kk);
		dpmul_(&mp1i[d1[p1]], &k1, &mp2r[d2[p2 + k]], &k2, &mp3i[d3[
			p3 + i__]], &k3);
 
	    }
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
 
    }
    return 0;
L500:
    if (*l == 0) {
	goto L600;
    }
    if (*m == 0) {
	goto L700;
    }
    p1 = -(*nl1);
    p3 = -(*l);
    k2 = d2[2] - d2[1] - 1;
    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k3 = 0;
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    kk = k3;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3r[d3[p3 + i__]
		    ], &kk);
	    mp3i[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1i[d1[p1 + i__]], &k1, &mp2r[1], &k2, &mp3i[d3[p3 + i__]
		    ], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L600:
    k1 = d1[2] - d1[1] - 1;
    p2 = -(*nl2);
    p3 = -(*m);
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	p2 += *nl2;
	p3 += *m;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    k3 = 0;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    kk = k3;
	    dpmul_(&mp1r[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__]
		    ], &kk);
	    mp3i[d3[p3 + i__]] = 0.;
	    dpmul_(&mp1i[1], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3i[d3[p3 + i__]
		    ], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L700:
    p1 = -(*nl1);
    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    dpmul_(&mp1r[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3r[
		    d3[p3 + i__]], &k3);
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    dpmul_(&mp1i[d1[p1 + i__]], &k1, &mp2r[d2[p2 + i__]], &k2, &mp3i[
		    d3[p3 + i__]], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
}  

 
  int wmdsp_(xr, xi, nx, m, n, maxc, mode, ll, lunit, cw, iw, 
	cw_len)
doublereal *xr, *xi;
integer *nx, *m, *n, *maxc, *mode, *ll, *lunit;
char *cw;
integer *iw;
ftnlen cw_len;
{
     
    static char fmt_130[] = "(\002(1pd\002,i2,\002.\002,i2,\002)\002)";
    static char fmt_120[] = "(\002(f\002,i2,\002.\002,i2,\002)\002)";

     
    address a__1[2], a__2[4];
    integer i__1, i__2, i__3, i__4[2], i__5[4], i__6;
    doublereal d__1, d__2;
    char ch__1[20], ch__2[27];
    icilist ici__1;

     
      int s_copy();
    integer s_wsfi(), do_fio(), e_wsfi();
    double d_lg10(), pow_di();
      int s_cat();
    integer s_cmp();

     
    static integer ldef;
    static doublereal fact;
    static integer imin, imax, ifmt;
    static char form[10*2];
    static integer lvar;
    static doublereal a;
    static integer i__, j, k, l, s, lbloc, nbloc;
    static doublereal a1, a2;
    static integer k1, k2, l1, n1, n2, l0, ib;
    static char dl[1];
    static integer fl, lf, nf, li, io, lp;
    extern   int basout_();
    static integer nl1, lgh;
    extern   int fmt_();
    static char sgn[1], var[4];
    static integer typ;

     
    static icilist io___3861 = { 0, form, 0, fmt_130, 10, 1 };


 
 
 
 
 

 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --iw;
    --xi;
    --xr;

     
    s_copy(var, "i", 4L, 1L);
    lvar = 1;

    s_copy(cw, " ", cw_len, 1L);
    s_wsfi(&io___3861);
    do_fio(&c__1, (char *)&(*maxc), (ftnlen)sizeof(integer));
    i__1 = *maxc - 7;
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    e_wsfi();
    *(unsigned char *)dl = ' ';
    if (*m * *n > 1) {
	*(unsigned char *)dl = '!';
    }

 

    fact = 1.;
    if (*m * *n == 1) {
	goto L2;
    }
    a1 = 0.;
    a2 = (( xr[1] ) >= 0 ? ( xr[1] ) : -( xr[1] ))  + (( xi[1] ) >= 0 ? ( xi[1] ) : -( xi[1] )) ;
    l = -(*nx);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	l += *nx;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    a = (d__1 = xr[l + i__], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = xi[l + i__], (( 
		    d__2 ) >= 0 ? (  		    d__2 ) : -(  		    d__2 )) );
	    if (a == 0.) {
		goto L1;
	    }
	    a1 = (( a1 ) >= ( a ) ? ( a1 ) : ( a )) ;
	    a2 = (( a2 ) <= ( a ) ? ( a2 ) : ( a )) ;
L1:
	    ;
	}
    }
    imax = 0;
    imin = 0;
    if (a1 > 0.) {
	imax = (integer) d_lg10(&a1);
    }
    if (a2 > 0.) {
	imin = (integer) d_lg10(&a2);
    }
    if (imax * imin <= 0) {
	goto L2;
    }
    imax = (imax + imin) / 2;
    if ((( imax ) >= 0 ? ( imax ) : -( imax ))  >= *maxc - 2) {
	i__2 = -imax;
	fact = pow_di(&c_b8137, &i__2);
    }
L2:

 
 
 
 
 
 
 

    lbloc = *n;
    lf = lbloc + 1 + *n;
    nbloc = 1;
    iw[lbloc + nbloc] = *n;
    s = 0;

    lp = -(*nx);
    ldef = lf;
    i__2 = *n;
    for (k = 1; k <= i__2; ++k) {
	lp += *nx;
	iw[k] = 0;
	i__1 = *m;
	for (l = 1; l <= i__1; ++l) {

 

	    lgh = 0;
	    for (i__ = 1; i__ <= 2; ++i__) {
		a = xr[lp + l] * fact;
		if (i__ == 2) {
		    a = xi[lp + l] * fact;
		}
		iw[ldef] = 0;
		if (a == 0.) {
		    goto L10;
		}

 
		typ = 1;
		if (*mode == 1) {
		    d__1 = (( a ) >= 0 ? ( a ) : -( a )) ;
		    fmt_(&d__1, maxc, &typ, &n1, &n2);
		}
		if (typ == 2) {
		    fl = n1;
		    iw[ldef] = n2 + (n1 << 5);
		} else if (typ < 0) {
		    iw[ldef] = typ;
		    fl = 3;
		} else {
		    iw[ldef] = 1;
		    fl = *maxc;
		    n2 = *maxc - 7;
		}

 

 

 

 
		lgh = fl + 2 + lgh;
 
L10:
		++ldef;
	    }

	    if (iw[ldef - 1] != 0) {
		lgh += lvar;
	    }
	    if (lgh == 0) {
		lgh = 4;
	    }
	    ++lgh;
 
	    i__3 = iw[k];
	    iw[k] = (( i__3 ) >= ( lgh ) ? ( i__3 ) : ( lgh )) ;

 
	}
	s += iw[k];
	if (s > *ll - 2) {
	    iw[lbloc + nbloc] = k - 1;
	    ++nbloc;
	    iw[lbloc + nbloc] = *n;
	    s = iw[k];
	}
 
    }
    if (fact != 1.) {
	ici__1.icierr = 0;
	ici__1.icirnum = 1;
	ici__1.icirlen = 12;
	ici__1.iciunit = cw;
	ici__1.icifmt = "(1x,1pd9.1,' *')";
	s_wsfi(&ici__1);
	d__1 = 1. / fact;
	do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
	e_wsfi();
	basout_(&io, lunit, cw, 12L);
	basout_(&io, lunit, " ", 1L);
	if (io == -1) {
	    goto L99;
	}
    }

 

 

    k1 = 1;
    i__2 = nbloc;
    for (ib = 1; ib <= i__2; ++ib) {
	k2 = iw[lbloc + ib];
	if (nbloc != 1) {
	    if (k1 == k2) {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 4;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__4[0] = 16, a__1[0] = "         column ";
		i__4[1] = 4, a__1[1] = cw;
		s_cat(ch__1, a__1, i__4, &c__2, 20L);
		basout_(&io, lunit, ch__1, 20L);
	    } else {
		ici__1.icierr = 0;
		ici__1.icirnum = 1;
		ici__1.icirlen = 8;
		ici__1.iciunit = cw;
		ici__1.icifmt = "(2i4)";
		s_wsfi(&ici__1);
		do_fio(&c__1, (char *)&k1, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&k2, (ftnlen)sizeof(integer));
		e_wsfi();
		basout_(&io, lunit, " ", 1L);
 
		i__5[0] = 16, a__2[0] = "        columns ";
		i__5[1] = 4, a__2[1] = cw;
		i__5[2] = 3, a__2[2] = " to";
		i__5[3] = 4, a__2[3] = cw + 4;
		s_cat(ch__2, a__2, i__5, &c__4, 27L);
		basout_(&io, lunit, ch__2, 27L);
		basout_(&io, lunit, " ", 1L);
	    }
	    basout_(&io, lunit, " ", 1L);
	    if (io == -1) {
		goto L99;
	    }
	}

	*(unsigned char *)cw = *(unsigned char *)dl;
	i__1 = *m;
	for (l = 1; l <= i__1; ++l) {
	    ldef = lf + (l - 1 + (k1 - 1) * *m << 1);
	    l1 = 2;
	    i__3 = k2;
	    for (k = k1; k <= i__3; ++k) {
		lp = (k - 1) * *nx + l;
		li = (k - 1) * *m + l;
		l0 = l1;

		for (i__ = 1; i__ <= 2; ++i__) {

		    ifmt = iw[ldef + i__ - 1];
		    if (ifmt == 0) {
			goto L42;
		    }

		    a = xr[lp];
		    if (i__ == 2) {
			a = xi[lp];
		    }
		    *(unsigned char *)sgn = ' ';
		    if (i__ == 2 && iw[ldef] != 0) {
			*(unsigned char *)sgn = '+';
		    }
		    if (a < 0.) {
			*(unsigned char *)sgn = '-';
		    }
		    a = (( a ) >= 0 ? ( a ) : -( a ))  * fact;

		    a = (( a ) >= 0 ? ( a ) : -( a )) ;

 
		    i__4[0] = 1, a__1[0] = " ";
		    i__4[1] = 1, a__1[1] = sgn;
		    s_cat(cw + (l1 - 1), a__1, i__4, &c__2, 2L);
		    l1 += 2;

		    if (ifmt == 1) {
			nf = 1;
			fl = *maxc;
			n2 = 1;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = l1 + fl - 1 - (l1 - 1);
			ici__1.iciunit = cw + (l1 - 1);
			ici__1.icifmt = form + (nf - 1) * 10;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
			e_wsfi();
		    } else if (ifmt >= 0) {
			nf = 2;
			n1 = ifmt / 32;
			n2 = ifmt - (n1 << 5);
			fl = n1;
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = 10;
			ici__1.iciunit = form + (nf - 1) * 10;
			ici__1.icifmt = fmt_120;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&fl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&n2, (ftnlen)sizeof(integer));
			e_wsfi();
			ici__1.icierr = 0;
			ici__1.icirnum = 1;
			ici__1.icirlen = l1 + fl - 1 - (l1 - 1);
			ici__1.iciunit = cw + (l1 - 1);
			ici__1.icifmt = form + (nf - 1) * 10;
			s_wsfi(&ici__1);
			do_fio(&c__1, (char *)&a, (ftnlen)sizeof(doublereal));
			e_wsfi();
		    } else if (ifmt == -1) {
 
			fl = 3;
			s_copy(cw + (l1 - 1), "Inf", l1 + fl - 1 - (l1 - 1), 
				3L);
		    } else if (ifmt == -2) {
 
			fl = 3;
			s_copy(cw + (l1 - 1), "Nan", l1 + fl - 1 - (l1 - 1), 
				3L);
		    }
		    l1 += fl;
L42:
		    ;
		}

		if (iw[ldef + 1] == 0) {
		    goto L43;
		}
		i__6 = l1 - 3;
		if (fl == 3 && s_cmp(cw + i__6, "1.", l1 - 1 - i__6, 2L) == 0)
			 {
		    l1 += -2;
		}
		s_copy(cw + (l1 - 1), var, l1 - 1 + lvar - (l1 - 1), lvar);
		l1 += lvar;
		goto L44;
L43:
		if (iw[ldef] != 0) {
		    goto L44;
		}
		s_copy(cw + (l1 - 1), "   0.", 4L, 5L);
		l1 += 4;

L44:
		nl1 = l0 + iw[k] - 1;
		s_copy(cw + (l1 - 1), " ", nl1 - (l1 - 1), 1L);
		l1 = nl1 + 1;
		ldef += *m << 1;
 
	    }
	    *(unsigned char *)&cw[l1 - 1] = *(unsigned char *)dl;
	    basout_(&io, lunit, cw, l1);
	    if (io == -1) {
		goto L99;
	    }
 
	}
	k1 = k2 + 1;
 
    }

L99:
    return 0;


}  

 
  int wmpad_(pm1r, pm1i, d1, l1, pm2r, pm2i, d2, l2, pm3r, 
	pm3i, d3, m, n)
doublereal *pm1r, *pm1i;
integer *d1, *l1;
doublereal *pm2r, *pm2i;
integer *d2, *l2;
doublereal *pm3r, *pm3i;
integer *d3, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k, i1, i2, k1, n1, n2, n3, k3, k2, mn;

 
 
 
 

 
 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 


     
    --d3;
    --pm3i;
    --pm3r;
    --d2;
    --pm2i;
    --pm2r;
    --d1;
    --pm1i;
    --pm1r;

     
    mn = *m * *n;

    d3[1] = 1;
    i1 = -(*l1);
    i2 = -(*l2);
    k3 = 0;
 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *l1;
	i2 += *l2;
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[i1 + i__] - 1;
	    k2 = d2[i2 + i__] - 1;
	    n1 = d1[i1 + i__ + 1] - d1[i1 + i__];
	    n2 = d2[i2 + i__ + 1] - d2[i2 + i__];
	    if (n1 > n2) {
		goto L15;
	    }

 

	    i__3 = n1;
	    for (k = 1; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k];
		pm3i[k3 + k] = pm1i[k1 + k] + pm2i[k2 + k];
 
	    }
	    if (n1 == n2) {
		goto L14;
	    }
	    n3 = n1 + 1;
	    i__3 = n2;
	    for (k = n3; k <= i__3; ++k) {
		pm3r[k3 + k] = pm2r[k2 + k];
 
		pm3i[k3 + k] = pm2i[k2 + k];
	    }
L14:
	    n3 = n2;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;
	    goto L18;

 

L15:
	    i__3 = n2;
	    for (k = 1; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k] + pm2r[k2 + k];
 
		pm3i[k3 + k] = pm1i[k1 + k] + pm2i[k2 + k];
	    }
	    n3 = n2 + 1;
	    i__3 = n1;
	    for (k = n3; k <= i__3; ++k) {
		pm3r[k3 + k] = pm1r[k1 + k];
 
		pm3i[k3 + k] = pm1i[k1 + k];
	    }
	    n3 = n1;
	    d3[i__ + 1 + (j - 1) * *m] = d3[i__ + (j - 1) * *m] + n3;

L18:
	    k1 += n1;
	    k2 += n2;
	    k3 += n3;
 
	}
    }
    return 0;
}  

 
  int wmpadj_(pm1r, pm1i, d1, m, n)
doublereal *pm1r, *pm1i;
integer *d1, *m, *n;
{
     
    integer i__1;
    doublereal d__1, d__2;

     
    static integer j;
    extern   int dcopy_();
    static integer k1, n1, dj, kk;

 
 

 

 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 


     
    --d1;
    --pm1i;
    --pm1r;

     
    kk = 1;
    dj = 1;
 
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	k1 = dj - 1;
	n1 = d1[j + 1] - dj + 1;
L10:
	--n1;
	if ((d__1 = pm1r[k1 + n1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = pm1i[k1 + n1], (( 
		d__2 ) >= 0 ? (  		d__2 ) : -(  		d__2 )) ) == 0. && n1 > 1) {
	    goto L10;
	}
	if (kk != k1 + 1) {
	    dcopy_(&n1, &pm1r[k1 + 1], &c__1, &pm1r[kk], &c__1);
	    dcopy_(&n1, &pm1i[k1 + 1], &c__1, &pm1i[kk], &c__1);
	}
	kk += n1;
	dj = d1[j + 1];
	d1[j + 1] = kk;
 
    }

    return 0;
}  

  int wmpcle_(pm1r, pm1i, d1, m, n, d2, epsr, epsa)
doublereal *pm1r, *pm1i;
integer *d1, *m, *n, *d2;
doublereal *epsr, *epsa;
{
     
    integer i__1, i__2;
    doublereal d__1, d__2;

     
    static integer lmin, lmax;
    static doublereal norm;
    static integer k, l;
    static doublereal normi, normr;
    static integer mn;
    static doublereal eps;

 
 
 
 
 

 

 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 



     
    --d2;
    --d1;
    --pm1i;
    --pm1r;

     
    mn = *m * *n;
    i__1 = mn;
    for (k = 1; k <= i__1; ++k) {
	lmin = d1[k];
	lmax = d1[k + 1] - 1;
	normr = 0.;
	normi = 0.;
	i__2 = lmax;
	for (l = lmin; l <= i__2; ++l) {
	    normr += (d__1 = pm1r[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    normi += (d__1 = pm1i[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) );
	    norm = normr + normi;
 
	}
 
	d__1 = *epsa, d__2 = *epsr * norm;
	eps = (( d__1 ) >= ( d__2 ) ? ( d__1 ) : ( d__2 )) ;
	i__2 = lmax;
	for (l = lmin; l <= i__2; ++l) {
	    if ((d__1 = pm1r[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) {
		pm1r[l] = 0.;
	    }
	    if ((d__1 = pm1i[l], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) <= eps) {
		pm1i[l] = 0.;
	    }
 
	}
 
    }
    return 0;
}  

 
  int wmpcnc_(mp1r, mp1i, d1, ld1, mp2r, mp2i, d2, ld2, mp3r, 
	mp3i, d3, l, m, n, job)
doublereal *mp1r, *mp1i;
integer *d1, *ld1;
doublereal *mp2r, *mp2i;
integer *d2, *ld2;
doublereal *mp3r, *mp3i;
integer *d3, *l, *m, *n, *job;
{
     
    integer i__1, i__2;

     
    extern   int dset_();
    static integer i__, j;
    extern   int dcopy_();
    static integer i1, i2, i3, np;

 
 
 
 
 
 
 

 
 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


     
    --d3;
    --mp3i;
    --mp3r;
    --d2;
    --mp2i;
    --mp2r;
    --d1;
    --mp1i;
    --mp1r;

     
    i3 = 1;
    d3[1] = 1;
    i1 = 1 - *ld1;
    i2 = 1 - *ld2;

    if (*job < 0) {
	goto L30;
    }

    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	np = d1[i1 + *l] - d1[i1];
	dcopy_(&np, &mp1r[d1[i1]], &c__1, &mp3r[d3[i3]], &c__1);
	if (*job != 2) {
	    dcopy_(&np, &mp1i[d1[i1]], &c__1, &mp3i[d3[i3]], &c__1);
	}
	if (*job == 2) {
	    dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1);
	}
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
 
    }
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i2 += *ld2;
	np = d2[i2 + *l] - d2[i2];
	dcopy_(&np, &mp2r[d2[i2]], &c__1, &mp3r[d3[i3]], &c__1);
	if (*job != 3) {
	    dcopy_(&np, &mp2i[d2[i2]], &c__1, &mp3i[d3[i3]], &c__1);
	}
	if (*job == 3) {
	    dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1);
	}
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;

L30:
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i1 += *ld1;
	i2 += *ld2;
	np = d1[i1 + *l] - d1[i1];
	dcopy_(&np, &mp1r[d1[i1]], &c__1, &mp3r[d3[i3]], &c__1);
	if (*job != -2) {
	    dcopy_(&np, &mp1i[d1[i1]], &c__1, &mp3i[d3[i3]], &c__1);
	}
	if (*job == -2) {
	    dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1);
	}
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d1[i1 + i__] - d1[i1 + i__ - 1];
 
	}
	np = d2[i2 + *m] - d2[i2];
	dcopy_(&np, &mp2r[d2[i2]], &c__1, &mp3r[d3[i3]], &c__1);
	if (*job != -3) {
	    dcopy_(&np, &mp2i[d2[i2]], &c__1, &mp3i[d3[i3]], &c__1);
	}
	if (*job == -3) {
	    dset_(&np, &c_b61, &mp3i[d3[i3]], &c__1);
	}
	i__2 = *m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++i3;
	    d3[i3] = d3[i3 - 1] + d2[i2 + i__] - d2[i2 + i__ - 1];
 
	}
 
    }
    return 0;
}  

 
  int wmpins_(mat1r, mat1i, dep1, lig1, col1, mat2r, mat2i, 
	dep2, lig2, col2, matrr, matri, depr, ligr, colr)
doublereal *mat1r, *mat1i;
integer *dep1, *lig1, *col1;
doublereal *mat2r, *mat2i;
integer *dep2, *lig2, *col2;
doublereal *matrr, *matri;
integer *depr, *ligr, *colr;
{
     
    integer i__1, i__2;

     
    static integer i__, j, l;
    extern   int dcopy_();
    static integer l1, l2, kr, lr;

 

 
 
 
 

 

 
 

 

 

 
 

 

 
 

 
 


 

 
 

 
 


 

     
    --depr;
    --matri;
    --matrr;
    --dep2;
    --mat2i;
    --mat2r;
    --dep1;
    --mat1i;
    --mat1r;

     
    depr[1] = 1;
    kr = 1;

    i__1 = *colr;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *ligr;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    ++kr;
	    lr = depr[kr];
	    if (lr < 0) {
		goto L11;
	    } else if (lr == 0) {
		goto L12;
	    } else {
		goto L13;
	    }
L11:
	    l2 = -lr;
	    l = dep2[l2 + 1] - dep2[l2];
	    dcopy_(&l, &mat2r[dep2[l2]], &c__1, &matrr[depr[kr - 1]], &c__1);
	    dcopy_(&l, &mat2i[dep2[l2]], &c__1, &matri[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;
	    goto L20;
L12:
	    matrr[depr[kr - 1]] = 0.;
	    matri[depr[kr - 1]] = 0.;
	    depr[kr] = depr[kr - 1] + 1;
	    goto L20;
L13:
	    l1 = lr;
	    l = dep1[l1 + 1] - dep1[l1];
	    dcopy_(&l, &mat1r[dep1[l1]], &c__1, &matrr[depr[kr - 1]], &c__1);
	    dcopy_(&l, &mat1i[dep1[l1]], &c__1, &matri[depr[kr - 1]], &c__1);
	    depr[kr] = depr[kr - 1] + l;

L20:
	    ;
	}
    }
    return 0;
}  

 
  int wmpmu_(mp1r, mp1i, d1, nl1, mp2r, mp2i, d2, nl2, mp3r, 
	mp3i, d3, l, m, n)
doublereal *mp1r, *mp1i;
integer *d1, *nl1;
doublereal *mp2r, *mp2i;
integer *d2, *nl2;
doublereal *mp3r, *mp3i;
integer *d3, *l, *m, *n;
{
     
    integer i__1, i__2, i__3;

     
    static integer i__, j, k, k1, k2, k3, p1, p2, p3;
    extern   int wpmul_();

 
 
 

 

 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
 
 

 
 
 

 
 
 

 
 
 


 




     
    --d3;
    --mp3i;
    --mp3r;
    --d2;
    --mp2i;
    --mp2r;
    --d1;
    --mp1i;
    --mp1r;

     
    d3[1] = 1;
    if (*l == 0 || *m == 0 || *n == 0) {
	goto L500;
    }

    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    p1 = i__ - *nl1;
	    i__3 = *m;
	    for (k = 1; k <= i__3; ++k) {
		p1 += *nl1;
		k2 = d2[p2 + k + 1] - d2[p2 + k] - 1;
		k1 = d1[p1 + 1] - d1[p1] - 1;
		wpmul_(&mp1r[d1[p1]], &mp1i[d1[p1]], &k1, &mp2r[d2[p2 + k]], &
			mp2i[d2[p2 + k]], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[
			p3 + i__]], &k3);
 
	    }
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
 
    }
    return 0;
L500:
    if (*l == 0) {
	goto L600;
    }
    if (*m == 0) {
	goto L700;
    }
    p1 = -(*nl1);
    p3 = -(*l);
    k2 = d2[2] - d2[1] - 1;
    i__1 = *m;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k3 = 0;
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    wpmul_(&mp1r[d1[p1 + i__]], &mp1i[d1[p1 + i__]], &k1, &mp2r[1], &
		    mp2i[1], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[p3 + i__]], &
		    k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L600:
    k1 = d1[2] - d1[1] - 1;
    p2 = -(*nl2);
    p3 = -(*m);
    i__2 = *n;
    for (j = 1; j <= i__2; ++j) {
	p2 += *nl2;
	p3 += *m;
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    k3 = 0;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    wpmul_(&mp1r[1], &mp1i[1], &k1, &mp2r[d2[p2 + i__]], &mp2i[d2[p2 
		    + i__]], &k2, &mp3r[d3[p3 + i__]], &mp3i[d3[p3 + i__]], &
		    k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
L700:
    p1 = -(*nl1);
    p2 = -(*nl2);
    p3 = -(*l);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	p1 += *nl1;
	p2 += *nl2;
	p3 += *l;
	i__2 = *l;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    k1 = d1[p1 + i__ + 1] - d1[p1 + i__] - 1;
	    k2 = d2[p2 + i__ + 1] - d2[p2 + i__] - 1;
	    mp3r[d3[p3 + i__]] = 0.;
	    mp3i[d3[p3 + i__]] = 0.;
	    k3 = 0;
	    wpmul_(&mp1r[d1[p1 + i__]], &mp1i[d1[p1 + i__]], &k1, &mp2r[d2[p2 
		    + i__]], &mp2i[d2[p2 + i__]], &k2, &mp3r[d3[p3 + i__]], &
		    mp3i[d3[p3 + i__]], &k3);
	    d3[p3 + i__ + 1] = d3[p3 + i__] + k3 + 1;
 
	}
    }
    return 0;
}  

 
  int wmptld_(pm1r, pm1i, d1, ld1, pm2r, pm2i, d2, m, n)
doublereal *pm1r, *pm1i;
integer *d1, *ld1;
doublereal *pm2r, *pm2i;
integer *d2, *m, *n;
{
     
    integer i__1, i__2, i__3;
    doublereal d__1, d__2;

     
    extern   int dset_();
    static integer nmax;
    static doublereal norm;
    static integer i__, j;
    extern   int dscal_(), dcopy_();
    static integer i1, i2;
    extern doublereal wasum_();
    static integer l1, l2, n1;

 
 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 

 
     
    --d2;
    --pm2i;
    --pm2r;
    --d1;
    --pm1i;
    --pm1r;

     
    d2[1] = 1;
    nmax = 0;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1 + 1;
	    i__3 = n1 - 1;
	    norm = wasum_(&i__3, &pm1r[l1], &pm1i[l1], &c__1);
L10:
	    --n1;
	    if ((d__1 = pm1r[l1 + n1 - 1], (( d__1 ) >= 0 ? ( d__1 ) : -( d__1 )) ) + (d__2 = pm1i[l1 + n1 
		    - 1], (( d__2 ) >= 0 ? ( d__2 ) : -( d__2 )) ) + norm <= norm) {
		goto L10;
	    }
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = n1;
	    nmax = (( nmax ) >= ( n1 ) ? ( nmax ) : ( n1 )) ;
 
	}
 
    }

 
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    n1 = d2[i2 + 1];
	    l2 = d2[i2];
	    if (n1 >= nmax) {
		goto L30;
	    }
	    i__3 = nmax - n1;
	    dset_(&i__3, &c_b61, &pm2r[l2], &c__1);
	    i__3 = nmax - n1;
	    dset_(&i__3, &c_b61, &pm2i[l2], &c__1);
L30:
	    dcopy_(&n1, &pm1r[l1], &c__1, &pm2r[l2], &c_n1);
	    dcopy_(&n1, &pm1i[l1], &c__1, &pm2i[l2], &c_n1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + nmax;
 
	}
 
    }

    i__1 = d2[*m * *n + 1] - 1;
    dscal_(&i__1, &c_b418, &pm2i[1], &c__1);

    return 0;
}  

 
  int wmptra_(pm1r, pm1i, d1, ld1, pm2r, pm2i, d2, m, n)
doublereal *pm1r, *pm1i;
integer *d1, *ld1;
doublereal *pm2r, *pm2i;
integer *d2, *m, *n;
{
     
    integer i__1, i__2;

     
    static integer i__, j;
    extern   int dscal_(), dcopy_();
    static integer i1, i2, l1, l2, n1;

 
 
 
 
 

 
 
 

 
 
 
 
 
 
 
 
 

 
 
 
 
 
 
 
     
    --d2;
    --pm2i;
    --pm2r;
    --d1;
    --pm1i;
    --pm1r;

     
    d2[1] = 1;
    i2 = 1;
    i__1 = *m;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i1 = i__;
	i__2 = *n;
	for (j = 1; j <= i__2; ++j) {
	    l1 = d1[i1];
	    n1 = d1[i1 + 1] - l1;
	    l2 = d2[i2];
	    dcopy_(&n1, &pm1r[l1], &c__1, &pm2r[l2], &c__1);
	    dcopy_(&n1, &pm1i[l1], &c__1, &pm2i[l2], &c__1);
	    i1 += *ld1;
	    ++i2;
	    d2[i2] = l2 + n1;
 
	}
 
    }
    i__1 = d2[*m * *n + 1] - 1;
    dscal_(&i__1, &c_b418, &pm2i[1], &c__1);

    return 0;
}  

 
  int wpmul_(p1r, p1i, d1, p2r, p2i, d2, p3r, p3i, d3)
doublereal *p1r, *p1i;
integer *d1;
doublereal *p2r, *p2i;
integer *d2;
doublereal *p3r, *p3i;
integer *d3;
{
     
    integer i__1, i__2, i__3;

     
    static integer dmin__, dmax__;
    extern doublereal ddot_();
    static integer dsum, i__, j, k, l, e1, e2;

 
 

 

 
 
 
 
 
 
 
 
 
 
 
     
    --p3i;
    --p3r;
    --p2i;
    --p2r;
    --p1i;
    --p1r;

     
    dsum = *d1 + *d2;
 
    dmax__ = *d1;
    if (*d2 > *d1) {
	dmax__ = *d2;
    }
    dmin__ = dsum - dmax__;
 
    if (*d3 >= dsum) {
	goto L1;
    }
    e1 = *d3 + 2;
    e2 = dsum + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	p3r[i__] = 0.;
	p3i[i__] = 0.;
 
    }
    *d3 = dsum;
L1:
 
    if (*d1 == 0 || *d2 == 0) {
	goto L53;
    }
 
    e1 = 1;
    e2 = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	p3r[i__] = p3r[i__] + ddot_(&i__, &p1r[1], &c__1, &p2r[1], &c_n1) - 
		ddot_(&i__, &p1i[1], &c__1, &p2i[1], &c_n1);
	p3i[i__] = p3i[i__] + ddot_(&i__, &p1r[1], &c__1, &p2i[1], &c_n1) + 
		ddot_(&i__, &p1i[1], &c__1, &p2r[1], &c_n1);
 
    }
    k = 1;
    if (*d1 == *d2) {
	goto L21;
    }
    e1 = dmin__ + 2;
    e2 = dmax__ + 1;
 
    if (*d1 < *d2) {
	goto L25;
    }
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	++k;
	i__2 = dmin__ + 1;
	i__3 = dmin__ + 1;
	p3r[i__] = p3r[i__] + ddot_(&i__2, &p1r[k], &c__1, &p2r[1], &c_n1) - 
		ddot_(&i__3, &p1i[k], &c__1, &p2i[1], &c_n1);
	i__2 = dmin__ + 1;
	i__3 = dmin__ + 1;
	p3i[i__] = p3i[i__] + ddot_(&i__2, &p1r[k], &c__1, &p2i[1], &c_n1) + 
		ddot_(&i__3, &p1i[k], &c__1, &p2r[1], &c_n1);
 
    }
L21:
    e1 = dmax__ + 2;
    e2 = dsum + 1;
    l = 1;
    j = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	--j;
	++k;
	++l;
	p3r[i__] = p3r[i__] + ddot_(&j, &p1r[k], &c__1, &p2r[l], &c_n1) - 
		ddot_(&j, &p1i[k], &c__1, &p2i[l], &c_n1);
	p3i[i__] = p3i[i__] + ddot_(&j, &p1r[k], &c__1, &p2i[l], &c_n1) + 
		ddot_(&j, &p1i[k], &c__1, &p2r[l], &c_n1);
 
    }
    return 0;
 
L25:
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	++k;
	i__2 = dmin__ + 1;
	i__3 = dmin__ + 1;
	p3r[i__] = p3r[i__] + ddot_(&i__2, &p2r[k], &c_n1, &p1r[1], &c__1) - 
		ddot_(&i__3, &p2i[k], &c_n1, &p1i[1], &c__1);
	i__2 = dmin__ + 1;
	i__3 = dmin__ + 1;
	p3i[i__] = p3i[i__] + ddot_(&i__2, &p2r[k], &c_n1, &p1i[1], &c__1) + 
		ddot_(&i__3, &p2i[k], &c_n1, &p1r[1], &c__1);
 
    }
    e1 = dmax__ + 2;
    e2 = dsum + 1;
    l = 1;
    j = dmin__ + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	--j;
	++k;
	++l;
	p3r[i__] = p3r[i__] + ddot_(&j, &p1r[l], &c__1, &p2r[k], &c_n1) - 
		ddot_(&j, &p1i[l], &c__1, &p2i[k], &c_n1);
	p3i[i__] = p3i[i__] + ddot_(&j, &p1r[l], &c__1, &p2i[k], &c_n1) + 
		ddot_(&j, &p1i[l], &c__1, &p2r[k], &c_n1);
 
    }
    return 0;
 
L53:
    if (*d1 == 0 && *d2 == 0) {
	goto L100;
    }
    e1 = 1;
    if (*d1 == 0) {
	goto L60;
    }
    e2 = *d1 + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	p3r[i__] = p3r[i__] + p1r[i__] * p2r[1] - p1i[i__] * p2i[1];
	p3i[i__] = p3i[i__] + p1r[i__] * p2i[1] + p1i[i__] * p2r[1];
 
    }
    return 0;
L60:
    e2 = *d2 + 1;
    i__1 = e2;
    for (i__ = e1; i__ <= i__1; ++i__) {
	p3r[i__] = p3r[i__] + p2r[i__] * p1r[1] - p2i[i__] * p1i[1];
	p3i[i__] = p3i[i__] + p2r[i__] * p1i[1] + p2i[i__] * p1r[1];
 
    }
    return 0;
L100:
    p3r[1] = p3r[1] + p1r[1] * p2r[1] - p1i[1] * p2i[1];
    p3i[1] = p3i[1] + p1r[1] * p2i[1] + p1i[1] * p2r[1];
    return 0;
}  

 
  int wpmul1_(p1r, p1i, d1, p2r, p2i, d2, p3r, p3i)
doublereal *p1r, *p1i;
integer *d1;
doublereal *p2r, *p2i;
integer *d2;
doublereal *p3r, *p3i;
{
     
    integer i__1;

     
    extern doublereal ddot_();
    static integer k, l, d3, l1, l2, l3, m3;
    static doublereal si, sr;

 
 

 

 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 

 
     
    --p3i;
    --p3r;
    --p2i;
    --p2r;
    --p1i;
    --p1r;

     
    l = 1;
    l1 = *d1 + 1;
    l2 = *d2 + 1;
    d3 = *d1 + *d2;
    l3 = d3 + 1;

    m3 = (( l1 ) <= ( l2 ) ? ( l1 ) : ( l2 )) ;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	sr = ddot_(&l, &p1r[l1], &c__1, &p2r[l2], &c_n1) - ddot_(&l, &p1i[l1],
		 &c__1, &p2i[l2], &c_n1);
	si = ddot_(&l, &p1r[l1], &c__1, &p2i[l2], &c_n1) + ddot_(&l, &p1i[l1],
		 &c__1, &p2r[l2], &c_n1);
	p3r[l3] = sr;
	p3i[l3] = si;
	++l;
	--l3;
	--l1;
	--l2;
 
    }
    --l;

    if (l1 == 0) {
	goto L30;
    }
    m3 = l1;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	sr = ddot_(&l, &p1r[l1], &c__1, &p2r[1], &c_n1) - ddot_(&l, &p1i[l1], 
		&c__1, &p2i[1], &c_n1);
	si = ddot_(&l, &p1r[l1], &c__1, &p2i[1], &c_n1) + ddot_(&l, &p1i[l1], 
		&c__1, &p2r[1], &c_n1);
	p3r[l3] = sr;
	p3i[l3] = si;
	--l1;
	--l3;
 
    }
    goto L40;
L30:
    if (l2 == 0) {
	goto L40;
    }
    m3 = l2;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	sr = ddot_(&l, &p1r[1], &c__1, &p2r[l2], &c_n1) - ddot_(&l, &p1i[1], &
		c__1, &p2i[l2], &c_n1);
	si = ddot_(&l, &p1r[1], &c__1, &p2i[l2], &c_n1) + ddot_(&l, &p1i[1], &
		c__1, &p2r[l2], &c_n1);
	p3r[l3] = sr;
	p3i[l3] = si;
	--l2;
	--l3;
 
    }

L40:
    if (l3 == 0) {
	return 0;
    }
    m3 = l3;
    i__1 = m3;
    for (k = 1; k <= i__1; ++k) {
	--l;
	sr = ddot_(&l, &p1r[1], &c__1, &p2r[1], &c_n1) - ddot_(&l, &p1i[1], &
		c__1, &p2i[1], &c_n1);
	si = ddot_(&l, &p1r[1], &c__1, &p2i[1], &c_n1) + ddot_(&l, &p1i[1], &
		c__1, &p2r[1], &c_n1);
	p3r[l3] = sr;
	p3i[l3] = si;
	--l3;
 
    }
    return 0;
}  

 
  int wpodiv_(ar, ai, br, bi, na, nb)
doublereal *ar, *ai, *br, *bi;
integer *na, *nb;
{
     
    integer i__1;

     
    extern   int wdiv_(), wmul_();
    static integer i__, l, n, n1, n2;
    static doublereal qi, wi, qr, wr;
    static integer nb1;

 
 

 
 
 
 
 
 
 
 
 

 
 
 

     
    --bi;
    --br;
    --ai;
    --ar;

     
    l = *na - *nb + 1;
L2:
    if (l <= 0) {
	goto L5;
    } else {
	goto L3;
    }
L3:
    n = l + *nb;
 
    wdiv_(&ar[n], &ai[n], &br[*nb + 1], &bi[*nb + 1], &qr, &qi);
    nb1 = *nb + 1;
    i__1 = nb1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	n1 = *nb - i__ + 2;
	n2 = n - i__ + 1;
 
	wmul_(&br[n1], &bi[n1], &qr, &qi, &wr, &wi);
	ar[n2] -= wr;
	ai[n2] -= wi;
 
    }
    ar[n] = qr;
    ai[n] = qi;
    --l;
    goto L2;
L5:
    return 0;
}  

 
  int wprxc_(n, rootr, rooti, coeffr, coeffi)
integer *n;
doublereal *rootr, *rooti, *coeffr, *coeffi;
{
     
    integer i__1;
    doublereal d__1, d__2;

     
    extern   int dset_();
    static integer j;
    extern   int waxpy_();
    static integer nj;

 
 
 


 
 
 
 

 
 
 
 
 
 
 
 
 


     
    --rooti;
    --rootr;
    --coeffr;
    --coeffi;

     
    dset_(n, &c_b61, &coeffr[1], &c__1);
    i__1 = *n + 1;
    dset_(&i__1, &c_b61, &coeffi[1], &c__1);
    coeffr[*n + 1] = 1.;

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	nj = *n + 1 - j;
	d__1 = -rootr[j];
	d__2 = -rooti[j];
	waxpy_(&j, &d__1, &d__2, &coeffr[nj + 1], &coeffi[nj + 1], &c__1, &
		coeffr[nj], &coeffi[nj], &c__1);
 
    }

    return 0;
}  

